TTG3 Combined Step 1 and 3 for Trees That Grow
[ghc.git] / compiler / hsSyn / Convert.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 This module converts Template Haskell syntax into HsSyn
7 -}
8
9 {-# LANGUAGE FlexibleContexts #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11 {-# LANGUAGE TypeFamilies #-}
12
13 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
14 convertToHsType,
15 thRdrNameGuesses ) where
16
17 import GhcPrelude
18
19 import HsSyn as Hs
20 import qualified Class
21 import RdrName
22 import qualified Name
23 import Module
24 import RdrHsSyn
25 import qualified OccName
26 import OccName
27 import SrcLoc
28 import Type
29 import qualified Coercion ( Role(..) )
30 import TysWiredIn
31 import TysPrim (eqPrimTyCon)
32 import BasicTypes as Hs
33 import ForeignCall
34 import Unique
35 import ErrUtils
36 import Bag
37 import Lexeme
38 import Util
39 import FastString
40 import Outputable
41 import MonadUtils ( foldrM )
42
43 import qualified Data.ByteString as BS
44 import Control.Monad( unless, liftM, ap, (<=<) )
45
46 import Data.Maybe( catMaybes, fromMaybe, isNothing )
47 import Language.Haskell.TH as TH hiding (sigP)
48 import Language.Haskell.TH.Syntax as TH
49
50 -------------------------------------------------------------------
51 -- The external interface
52
53 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
54 convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
55 where
56 cvt_dec d = wrapMsg "declaration" d (cvtDec d)
57
58 convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
59 convertToHsExpr loc e
60 = initCvt loc $ wrapMsg "expression" e $ cvtl e
61
62 convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
63 convertToPat loc p
64 = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
65
66 convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
67 convertToHsType loc t
68 = initCvt loc $ wrapMsg "type" t $ cvtType t
69
70 -------------------------------------------------------------------
71 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
72 -- Push down the source location;
73 -- Can fail, with a single error message
74
75 -- NB: If the conversion succeeds with (Right x), there should
76 -- be no exception values hiding in x
77 -- Reason: so a (head []) in TH code doesn't subsequently
78 -- make GHC crash when it tries to walk the generated tree
79
80 -- Use the loc everywhere, for lack of anything better
81 -- In particular, we want it on binding locations, so that variables bound in
82 -- the spliced-in declarations get a location that at least relates to the splice point
83
84 instance Functor CvtM where
85 fmap = liftM
86
87 instance Applicative CvtM where
88 pure x = CvtM $ \loc -> Right (loc,x)
89 (<*>) = ap
90
91 instance Monad CvtM where
92 (CvtM m) >>= k = CvtM $ \loc -> case m loc of
93 Left err -> Left err
94 Right (loc',v) -> unCvtM (k v) loc'
95
96 initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
97 initCvt loc (CvtM m) = fmap snd (m loc)
98
99 force :: a -> CvtM ()
100 force a = a `seq` return ()
101
102 failWith :: MsgDoc -> CvtM a
103 failWith m = CvtM (\_ -> Left m)
104
105 getL :: CvtM SrcSpan
106 getL = CvtM (\loc -> Right (loc,loc))
107
108 setL :: SrcSpan -> CvtM ()
109 setL loc = CvtM (\_ -> Right (loc, ()))
110
111 returnL :: a -> CvtM (Located a)
112 returnL x = CvtM (\loc -> Right (loc, L loc x))
113
114 returnJustL :: a -> CvtM (Maybe (Located a))
115 returnJustL = fmap Just . returnL
116
117 wrapParL :: (Located a -> a) -> a -> CvtM a
118 wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x)))
119
120 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
121 -- E.g wrapMsg "declaration" dec thing
122 wrapMsg what item (CvtM m)
123 = CvtM (\loc -> case m loc of
124 Left err -> Left (err $$ getPprStyle msg)
125 Right v -> Right v)
126 where
127 -- Show the item in pretty syntax normally,
128 -- but with all its constructors if you say -dppr-debug
129 msg sty = hang (text "When splicing a TH" <+> text what <> colon)
130 2 (if debugStyle sty
131 then text (show item)
132 else text (pprint item))
133
134 wrapL :: CvtM a -> CvtM (Located a)
135 wrapL (CvtM m) = CvtM (\loc -> case m loc of
136 Left err -> Left err
137 Right (loc',v) -> Right (loc',L loc v))
138
139 -------------------------------------------------------------------
140 cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
141 cvtDecs = fmap catMaybes . mapM cvtDec
142
143 cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
144 cvtDec (TH.ValD pat body ds)
145 | TH.VarP s <- pat
146 = do { s' <- vNameL s
147 ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
148 ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
149
150 | otherwise
151 = do { pat' <- cvtPat pat
152 ; body' <- cvtGuard body
153 ; ds' <- cvtLocalDecs (text "a where clause") ds
154 ; returnJustL $ Hs.ValD $
155 PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
156 , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
157 , pat_ticks = ([],[]) } }
158
159 cvtDec (TH.FunD nm cls)
160 | null cls
161 = failWith (text "Function binding for"
162 <+> quotes (text (TH.pprint nm))
163 <+> text "has no equations")
164 | otherwise
165 = do { nm' <- vNameL nm
166 ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
167 ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
168
169 cvtDec (TH.SigD nm typ)
170 = do { nm' <- vNameL nm
171 ; ty' <- cvtType typ
172 ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
173
174 cvtDec (TH.InfixD fx nm)
175 -- Fixity signatures are allowed for variables, constructors, and types
176 -- the renamer automatically looks for types during renaming, even when
177 -- the RdrName says it's a variable or a constructor. So, just assume
178 -- it's a variable or constructor and proceed.
179 = do { nm' <- vcNameL nm
180 ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
181
182 cvtDec (PragmaD prag)
183 = cvtPragmaD prag
184
185 cvtDec (TySynD tc tvs rhs)
186 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
187 ; rhs' <- cvtType rhs
188 ; returnJustL $ TyClD $
189 SynDecl { tcdLName = tc', tcdTyVars = tvs'
190 , tcdFixity = Prefix
191 , tcdFVs = placeHolderNames
192 , tcdRhs = rhs' } }
193
194 cvtDec (DataD ctxt tc tvs ksig constrs derivs)
195 = do { let isGadtCon (GadtC _ _ _) = True
196 isGadtCon (RecGadtC _ _ _) = True
197 isGadtCon (ForallC _ _ c) = isGadtCon c
198 isGadtCon _ = False
199 isGadtDecl = all isGadtCon constrs
200 isH98Decl = all (not . isGadtCon) constrs
201 ; unless (isGadtDecl || isH98Decl)
202 (failWith (text "Cannot mix GADT constructors with Haskell 98"
203 <+> text "constructors"))
204 ; unless (isNothing ksig || isGadtDecl)
205 (failWith (text "Kind signatures are only allowed on GADTs"))
206 ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
207 ; ksig' <- cvtKind `traverse` ksig
208 ; cons' <- mapM cvtConstr constrs
209 ; derivs' <- cvtDerivs derivs
210 ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
211 , dd_ctxt = ctxt'
212 , dd_kindSig = ksig'
213 , dd_cons = cons', dd_derivs = derivs' }
214 ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
215 , tcdFixity = Prefix
216 , tcdDataDefn = defn
217 , tcdDataCusk = placeHolder
218 , tcdFVs = placeHolderNames }) }
219
220 cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
221 = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
222 ; ksig' <- cvtKind `traverse` ksig
223 ; con' <- cvtConstr constr
224 ; derivs' <- cvtDerivs derivs
225 ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
226 , dd_ctxt = ctxt'
227 , dd_kindSig = ksig'
228 , dd_cons = [con']
229 , dd_derivs = derivs' }
230 ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
231 , tcdFixity = Prefix
232 , tcdDataDefn = defn
233 , tcdDataCusk = placeHolder
234 , tcdFVs = placeHolderNames }) }
235
236 cvtDec (ClassD ctxt cl tvs fds decs)
237 = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
238 ; fds' <- mapM cvt_fundep fds
239 ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs
240 ; unless (null adts')
241 (failWith $ (text "Default data instance declarations"
242 <+> text "are not allowed:")
243 $$ (Outputable.ppr adts'))
244 ; at_defs <- mapM cvt_at_def ats'
245 ; returnJustL $ TyClD $
246 ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
247 , tcdFixity = Prefix
248 , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
249 , tcdMeths = binds'
250 , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
251 , tcdFVs = placeHolderNames }
252 -- no docs in TH ^^
253 }
254 where
255 cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)
256 -- Very similar to what happens in RdrHsSyn.mkClassDecl
257 cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
258 Right def -> return def
259 Left (_, msg) -> failWith msg
260
261 cvtDec (InstanceD o ctxt ty decs)
262 = do { let doc = text "an instance declaration"
263 ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
264 ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
265 ; ctxt' <- cvtContext ctxt
266 ; L loc ty' <- cvtType ty
267 ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
268 ; returnJustL $ InstD $ ClsInstD $
269 ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
270 , cid_binds = binds'
271 , cid_sigs = Hs.mkClassOpSigs sigs'
272 , cid_tyfam_insts = ats', cid_datafam_insts = adts'
273 , cid_overlap_mode = fmap (L loc . overlap) o } }
274 where
275 overlap pragma =
276 case pragma of
277 TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS")
278 TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE")
279 TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING")
280 TH.Incoherent -> Hs.Incoherent (SourceText "INCOHERENT")
281
282
283
284
285 cvtDec (ForeignD ford)
286 = do { ford' <- cvtForD ford
287 ; returnJustL $ ForD ford' }
288
289 cvtDec (DataFamilyD tc tvs kind)
290 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
291 ; result <- cvtMaybeKindToFamilyResultSig kind
292 ; returnJustL $ TyClD $ FamDecl $
293 FamilyDecl DataFamily tc' tvs' Prefix result Nothing }
294
295 cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
296 = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
297 ; ksig' <- cvtKind `traverse` ksig
298 ; cons' <- mapM cvtConstr constrs
299 ; derivs' <- cvtDerivs derivs
300 ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
301 , dd_ctxt = ctxt'
302 , dd_kindSig = ksig'
303 , dd_cons = cons', dd_derivs = derivs' }
304
305 ; returnJustL $ InstD $ DataFamInstD
306 { dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
307 FamEqn { feqn_tycon = tc', feqn_pats = typats'
308 , feqn_rhs = defn
309 , feqn_fixity = Prefix } }}}
310
311 cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
312 = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
313 ; ksig' <- cvtKind `traverse` ksig
314 ; con' <- cvtConstr constr
315 ; derivs' <- cvtDerivs derivs
316 ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
317 , dd_ctxt = ctxt'
318 , dd_kindSig = ksig'
319 , dd_cons = [con'], dd_derivs = derivs' }
320 ; returnJustL $ InstD $ DataFamInstD
321 { dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
322 FamEqn { feqn_tycon = tc', feqn_pats = typats'
323 , feqn_rhs = defn
324 , feqn_fixity = Prefix } }}}
325
326 cvtDec (TySynInstD tc eqn)
327 = do { tc' <- tconNameL tc
328 ; L _ eqn' <- cvtTySynEqn tc' eqn
329 ; returnJustL $ InstD $ TyFamInstD
330 { tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
331
332 cvtDec (OpenTypeFamilyD head)
333 = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
334 ; returnJustL $ TyClD $ FamDecl $
335 FamilyDecl OpenTypeFamily tc' tyvars' Prefix result' injectivity' }
336
337 cvtDec (ClosedTypeFamilyD head eqns)
338 = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
339 ; eqns' <- mapM (cvtTySynEqn tc') eqns
340 ; returnJustL $ TyClD $ FamDecl $
341 FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result'
342 injectivity' }
343
344 cvtDec (TH.RoleAnnotD tc roles)
345 = do { tc' <- tconNameL tc
346 ; let roles' = map (noLoc . cvtRole) roles
347 ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
348
349 cvtDec (TH.StandaloneDerivD ds cxt ty)
350 = do { cxt' <- cvtContext cxt
351 ; L loc ty' <- cvtType ty
352 ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
353 ; returnJustL $ DerivD $
354 DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
355 , deriv_type = mkLHsSigType inst_ty'
356 , deriv_overlap_mode = Nothing } }
357
358 cvtDec (TH.DefaultSigD nm typ)
359 = do { nm' <- vNameL nm
360 ; ty' <- cvtType typ
361 ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
362
363 cvtDec (TH.PatSynD nm args dir pat)
364 = do { nm' <- cNameL nm
365 ; args' <- cvtArgs args
366 ; dir' <- cvtDir nm' dir
367 ; pat' <- cvtPat pat
368 ; returnJustL $ Hs.ValD $ PatSynBind $
369 PSB nm' placeHolderType args' pat' dir' }
370 where
371 cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args
372 cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2
373 cvtArgs (TH.RecordPatSyn sels)
374 = do { sels' <- mapM vNameL sels
375 ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
376 ; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }
377
378 cvtDir _ Unidir = return Unidirectional
379 cvtDir _ ImplBidir = return ImplicitBidirectional
380 cvtDir n (ExplBidir cls) =
381 do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
382 ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
383
384 cvtDec (TH.PatSynSigD nm ty)
385 = do { nm' <- cNameL nm
386 ; ty' <- cvtPatSynSigTy ty
387 ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') }
388
389 ----------------
390 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
391 cvtTySynEqn tc (TySynEqn lhs rhs)
392 = do { lhs' <- mapM (wrap_apps <=< cvtType) lhs
393 ; rhs' <- cvtType rhs
394 ; returnL $ mkHsImplicitBndrs
395 $ FamEqn { feqn_tycon = tc
396 , feqn_pats = lhs'
397 , feqn_fixity = Prefix
398 , feqn_rhs = rhs' } }
399
400 ----------------
401 cvt_ci_decs :: MsgDoc -> [TH.Dec]
402 -> CvtM (LHsBinds GhcPs,
403 [LSig GhcPs],
404 [LFamilyDecl GhcPs],
405 [LTyFamInstDecl GhcPs],
406 [LDataFamInstDecl GhcPs])
407 -- Convert the declarations inside a class or instance decl
408 -- ie signatures, bindings, and associated types
409 cvt_ci_decs doc decs
410 = do { decs' <- cvtDecs decs
411 ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
412 ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs'
413 ; let (sigs', prob_binds') = partitionWith is_sig no_ats'
414 ; let (binds', prob_fams') = partitionWith is_bind prob_binds'
415 ; let (fams', bads) = partitionWith is_fam_decl prob_fams'
416 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
417 --We use FromSource as the origin of the bind
418 -- because the TH declaration is user-written
419 ; return (listToBag binds', sigs', fams', ats', adts') }
420
421 ----------------
422 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
423 -> CvtM ( LHsContext GhcPs
424 , Located RdrName
425 , LHsQTyVars GhcPs)
426 cvt_tycl_hdr cxt tc tvs
427 = do { cxt' <- cvtContext cxt
428 ; tc' <- tconNameL tc
429 ; tvs' <- cvtTvs tvs
430 ; return (cxt', tc', tvs')
431 }
432
433 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
434 -> CvtM ( LHsContext GhcPs
435 , Located RdrName
436 , HsTyPats GhcPs)
437 cvt_tyinst_hdr cxt tc tys
438 = do { cxt' <- cvtContext cxt
439 ; tc' <- tconNameL tc
440 ; tys' <- mapM (wrap_apps <=< cvtType) tys
441 ; return (cxt', tc', tys') }
442
443 ----------------
444 cvt_tyfam_head :: TypeFamilyHead
445 -> CvtM ( Located RdrName
446 , LHsQTyVars GhcPs
447 , Hs.LFamilyResultSig GhcPs
448 , Maybe (Hs.LInjectivityAnn GhcPs))
449
450 cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
451 = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars
452 ; result' <- cvtFamilyResultSig result
453 ; injectivity' <- traverse cvtInjectivityAnnotation injectivity
454 ; return (tc', tyvars', result', injectivity') }
455
456 -------------------------------------------------------------------
457 -- Partitioning declarations
458 -------------------------------------------------------------------
459
460 is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
461 is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
462 is_fam_decl decl = Right decl
463
464 is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
465 is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
466 is_tyfam_inst decl = Right decl
467
468 is_datafam_inst :: LHsDecl GhcPs
469 -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
470 is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
471 is_datafam_inst decl = Right decl
472
473 is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
474 is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
475 is_sig decl = Right decl
476
477 is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
478 is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
479 is_bind decl = Right decl
480
481 mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
482 mkBadDecMsg doc bads
483 = sep [ text "Illegal declaration(s) in" <+> doc <> colon
484 , nest 2 (vcat (map Outputable.ppr bads)) ]
485
486 ---------------------------------------------------
487 -- Data types
488 ---------------------------------------------------
489
490 cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
491
492 cvtConstr (NormalC c strtys)
493 = do { c' <- cNameL c
494 ; cxt' <- returnL []
495 ; tys' <- mapM cvt_arg strtys
496 ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
497
498 cvtConstr (RecC c varstrtys)
499 = do { c' <- cNameL c
500 ; cxt' <- returnL []
501 ; args' <- mapM cvt_id_arg varstrtys
502 ; returnL $ mkConDeclH98 c' Nothing cxt'
503 (RecCon (noLoc args')) }
504
505 cvtConstr (InfixC st1 c st2)
506 = do { c' <- cNameL c
507 ; cxt' <- returnL []
508 ; st1' <- cvt_arg st1
509 ; st2' <- cvt_arg st2
510 ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
511
512 cvtConstr (ForallC tvs ctxt con)
513 = do { tvs' <- cvtTvs tvs
514 ; L loc ctxt' <- cvtContext ctxt
515 ; L _ con' <- cvtConstr con
516 ; returnL $ case con' of
517 ConDeclGADT { con_type = conT } ->
518 let hs_ty = mkHsForAllTy tvs noSrcSpan tvs' rho_ty
519 rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt')
520 (hsib_body conT)
521 in con' { con_type = mkHsImplicitBndrs hs_ty }
522 ConDeclH98 {} ->
523 let qvars = case (tvs, con_qvars con') of
524 ([], Nothing) -> Nothing
525 (_ , m_qvs ) -> Just $
526 mkHsQTvs (hsQTvExplicit tvs' ++
527 maybe [] hsQTvExplicit m_qvs)
528 in con' { con_qvars = qvars
529 , con_cxt = Just $
530 L loc (ctxt' ++
531 unLoc (fromMaybe (noLoc [])
532 (con_cxt con'))) } }
533
534 cvtConstr (GadtC c strtys ty)
535 = do { c' <- mapM cNameL c
536 ; args <- mapM cvt_arg strtys
537 ; L _ ty' <- cvtType ty
538 ; c_ty <- mk_arr_apps args ty'
539 ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
540
541 cvtConstr (RecGadtC c varstrtys ty)
542 = do { c' <- mapM cNameL c
543 ; ty' <- cvtType ty
544 ; rec_flds <- mapM cvt_id_arg varstrtys
545 ; let rec_ty = noLoc (HsFunTy noExt
546 (noLoc $ HsRecTy noExt rec_flds) ty')
547 ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
548
549 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
550 cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
551 cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack
552 cvtSrcUnpackedness SourceUnpack = SrcUnpack
553
554 cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
555 cvtSrcStrictness NoSourceStrictness = NoSrcStrict
556 cvtSrcStrictness SourceLazy = SrcLazy
557 cvtSrcStrictness SourceStrict = SrcStrict
558
559 cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
560 cvt_arg (Bang su ss, ty)
561 = do { ty'' <- cvtType ty
562 ; ty' <- wrap_apps ty''
563 ; let su' = cvtSrcUnpackedness su
564 ; let ss' = cvtSrcStrictness ss
565 ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }
566
567 cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
568 cvt_id_arg (i, str, ty)
569 = do { L li i' <- vNameL i
570 ; ty' <- cvt_arg (str,ty)
571 ; return $ noLoc (ConDeclField
572 { cd_fld_names
573 = [L li $ FieldOcc noExt (L li i')]
574 , cd_fld_type = ty'
575 , cd_fld_doc = Nothing}) }
576
577 cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
578 cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
579 ; returnL cs' }
580
581 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
582 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
583 ; ys' <- mapM tNameL ys
584 ; returnL (xs', ys') }
585
586
587 ------------------------------------------
588 -- Foreign declarations
589 ------------------------------------------
590
591 cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
592 cvtForD (ImportF callconv safety from nm ty)
593 -- the prim and javascript calling conventions do not support headers
594 -- and are inserted verbatim, analogous to mkImport in RdrHsSyn
595 | callconv == TH.Prim || callconv == TH.JavaScript
596 = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
597 (CFunction (StaticTarget (SourceText from)
598 (mkFastString from) Nothing
599 True))
600 (noLoc $ quotedSourceText from))
601 | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
602 (mkFastString (TH.nameBase nm))
603 from (noLoc $ quotedSourceText from)
604 = mk_imp impspec
605 | otherwise
606 = failWith $ text (show from) <+> text "is not a valid ccall impent"
607 where
608 mk_imp impspec
609 = do { nm' <- vNameL nm
610 ; ty' <- cvtType ty
611 ; return (ForeignImport { fd_name = nm'
612 , fd_sig_ty = mkLHsSigType ty'
613 , fd_co = noForeignImportCoercionYet
614 , fd_fi = impspec })
615 }
616 safety' = case safety of
617 Unsafe -> PlayRisky
618 Safe -> PlaySafe
619 Interruptible -> PlayInterruptible
620
621 cvtForD (ExportF callconv as nm ty)
622 = do { nm' <- vNameL nm
623 ; ty' <- cvtType ty
624 ; let e = CExport (noLoc (CExportStatic (SourceText as)
625 (mkFastString as)
626 (cvt_conv callconv)))
627 (noLoc (SourceText as))
628 ; return $ ForeignExport { fd_name = nm'
629 , fd_sig_ty = mkLHsSigType ty'
630 , fd_co = noForeignExportCoercionYet
631 , fd_fe = e } }
632
633 cvt_conv :: TH.Callconv -> CCallConv
634 cvt_conv TH.CCall = CCallConv
635 cvt_conv TH.StdCall = StdCallConv
636 cvt_conv TH.CApi = CApiConv
637 cvt_conv TH.Prim = PrimCallConv
638 cvt_conv TH.JavaScript = JavaScriptCallConv
639
640 ------------------------------------------
641 -- Pragmas
642 ------------------------------------------
643
644 cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
645 cvtPragmaD (InlineP nm inline rm phases)
646 = do { nm' <- vNameL nm
647 ; let dflt = dfltActivation inline
648 ; let src TH.NoInline = "{-# NOINLINE"
649 src TH.Inline = "{-# INLINE"
650 src TH.Inlinable = "{-# INLINABLE"
651 ; let ip = InlinePragma { inl_src = SourceText $ src inline
652 , inl_inline = cvtInline inline
653 , inl_rule = cvtRuleMatch rm
654 , inl_act = cvtPhases phases dflt
655 , inl_sat = Nothing }
656 ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
657
658 cvtPragmaD (SpecialiseP nm ty inline phases)
659 = do { nm' <- vNameL nm
660 ; ty' <- cvtType ty
661 ; let src TH.NoInline = "{-# SPECIALISE NOINLINE"
662 src TH.Inline = "{-# SPECIALISE INLINE"
663 src TH.Inlinable = "{-# SPECIALISE INLINE"
664 ; let (inline', dflt,srcText) = case inline of
665 Just inline1 -> (cvtInline inline1, dfltActivation inline1,
666 src inline1)
667 Nothing -> (NoUserInline, AlwaysActive,
668 "{-# SPECIALISE")
669 ; let ip = InlinePragma { inl_src = SourceText srcText
670 , inl_inline = inline'
671 , inl_rule = Hs.FunLike
672 , inl_act = cvtPhases phases dflt
673 , inl_sat = Nothing }
674 ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
675
676 cvtPragmaD (SpecialiseInstP ty)
677 = do { ty' <- cvtType ty
678 ; returnJustL $ Hs.SigD $
679 SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
680
681 cvtPragmaD (RuleP nm bndrs lhs rhs phases)
682 = do { let nm' = mkFastString nm
683 ; let act = cvtPhases phases AlwaysActive
684 ; bndrs' <- mapM cvtRuleBndr bndrs
685 ; lhs' <- cvtl lhs
686 ; rhs' <- cvtl rhs
687 ; returnJustL $ Hs.RuleD
688 $ HsRules (SourceText "{-# RULES")
689 [noLoc $ HsRule (noLoc (SourceText nm,nm')) act bndrs'
690 lhs' placeHolderNames
691 rhs' placeHolderNames]
692 }
693
694 cvtPragmaD (AnnP target exp)
695 = do { exp' <- cvtl exp
696 ; target' <- case target of
697 ModuleAnnotation -> return ModuleAnnProvenance
698 TypeAnnotation n -> do
699 n' <- tconName n
700 return (TypeAnnProvenance (noLoc n'))
701 ValueAnnotation n -> do
702 n' <- vcName n
703 return (ValueAnnProvenance (noLoc n'))
704 ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target'
705 exp'
706 }
707
708 cvtPragmaD (LineP line file)
709 = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
710 ; return Nothing
711 }
712 cvtPragmaD (CompleteP cls mty)
713 = do { cls' <- noLoc <$> mapM cNameL cls
714 ; mty' <- traverse tconNameL mty
715 ; returnJustL $ Hs.SigD
716 $ CompleteMatchSig NoSourceText cls' mty' }
717
718 dfltActivation :: TH.Inline -> Activation
719 dfltActivation TH.NoInline = NeverActive
720 dfltActivation _ = AlwaysActive
721
722 cvtInline :: TH.Inline -> Hs.InlineSpec
723 cvtInline TH.NoInline = Hs.NoInline
724 cvtInline TH.Inline = Hs.Inline
725 cvtInline TH.Inlinable = Hs.Inlinable
726
727 cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
728 cvtRuleMatch TH.ConLike = Hs.ConLike
729 cvtRuleMatch TH.FunLike = Hs.FunLike
730
731 cvtPhases :: TH.Phases -> Activation -> Activation
732 cvtPhases AllPhases dflt = dflt
733 cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i
734 cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i
735
736 cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
737 cvtRuleBndr (RuleVar n)
738 = do { n' <- vNameL n
739 ; return $ noLoc $ Hs.RuleBndr n' }
740 cvtRuleBndr (TypedRuleVar n ty)
741 = do { n' <- vNameL n
742 ; ty' <- cvtType ty
743 ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' }
744
745 ---------------------------------------------------
746 -- Declarations
747 ---------------------------------------------------
748
749 cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
750 cvtLocalDecs doc ds
751 | null ds
752 = return EmptyLocalBinds
753 | otherwise
754 = do { ds' <- cvtDecs ds
755 ; let (binds, prob_sigs) = partitionWith is_bind ds'
756 ; let (sigs, bads) = partitionWith is_sig prob_sigs
757 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
758 ; return (HsValBinds (ValBinds noExt (listToBag binds) sigs)) }
759
760 cvtClause :: HsMatchContext RdrName
761 -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
762 cvtClause ctxt (Clause ps body wheres)
763 = do { ps' <- cvtPats ps
764 ; pps <- mapM wrap_conpat ps'
765 ; g' <- cvtGuard body
766 ; ds' <- cvtLocalDecs (text "a where clause") wheres
767 ; returnL $ Hs.Match ctxt pps (GRHSs g' (noLoc ds')) }
768
769
770 -------------------------------------------------------------------
771 -- Expressions
772 -------------------------------------------------------------------
773
774 cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
775 cvtl e = wrapL (cvt e)
776 where
777 cvt (VarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
778 cvt (ConE s) = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
779 cvt (LitE l)
780 | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit noExt l' }
781 | otherwise = do { l' <- cvtLit l; return $ HsLit noExt l' }
782 cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
783 ; return $ HsApp noExt (mkLHsPar x')
784 (mkLHsPar y')}
785 cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y
786 ; return $ HsApp noExt (mkLHsPar x')
787 (mkLHsPar y')}
788 cvt (AppTypeE e t) = do { e' <- cvtl e
789 ; t' <- cvtType t
790 ; tp <- wrap_apps t'
791 ; return $ HsAppType (mkHsWildCardBndrs tp) e' }
792 cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its
793 -- own expression to avoid pretty-printing
794 -- oddities that can result from zero-argument
795 -- lambda expressions. See #13856.
796 cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
797 ; return $ HsLam noExt (mkMatchGroup FromSource
798 [mkSimpleMatch LambdaExpr ps' e'])}
799 cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms
800 ; return $ HsLamCase noExt
801 (mkMatchGroup FromSource ms')
802 }
803 cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar noExt e' }
804 -- Note [Dropping constructors]
805 -- Singleton tuples treated like nothing (just parens)
806 cvt (TupE es) = do { es' <- mapM cvtl es
807 ; return $ ExplicitTuple noExt
808 (map (noLoc . (Present noExt)) es')
809 Boxed }
810 cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
811 ; return $ ExplicitTuple noExt
812 (map (noLoc . (Present noExt)) es')
813 Unboxed }
814 cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
815 ; unboxedSumChecks alt arity
816 ; return $ ExplicitSum noExt
817 alt arity e'}
818 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
819 ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }
820 cvt (MultiIfE alts)
821 | null alts = failWith (text "Multi-way if-expression with no alternatives")
822 | otherwise = do { alts' <- mapM cvtpair alts
823 ; return $ HsMultiIf noExt alts' }
824 cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds
825 ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}
826 cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
827 ; return $ HsCase noExt e'
828 (mkMatchGroup FromSource ms') }
829 cvt (DoE ss) = cvtHsDo DoExpr ss
830 cvt (CompE ss) = cvtHsDo ListComp ss
831 cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
832 ; return $ ArithSeq noExt Nothing dd' }
833 cvt (ListE xs)
834 | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s)
835 ; return (HsLit noExt l') }
836 -- Note [Converting strings]
837 | otherwise = do { xs' <- mapM cvtl xs
838 ; return $ ExplicitList noExt Nothing xs'
839 }
840
841 -- Infix expressions
842 cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
843 ; wrapParL (HsPar noExt) $
844 OpApp noExt (mkLHsPar x') s'
845 (mkLHsPar y') }
846 -- Parenthesise both arguments and result,
847 -- to ensure this operator application does
848 -- does not get re-associated
849 -- See Note [Operator association]
850 cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
851 ; wrapParL (HsPar noExt)
852 $ SectionR noExt s' y' }
853 -- See Note [Sections in HsSyn] in HsExpr
854 cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
855 ; wrapParL (HsPar noExt)
856 $ SectionL noExt x' s' }
857
858 cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s
859 ; return $ HsPar noExt s' }
860 -- Can I indicate this is an infix thing?
861 -- Note [Dropping constructors]
862
863 cvt (UInfixE x s y) = do { x' <- cvtl x
864 ; let x'' = case x' of
865 L _ (OpApp {}) -> x'
866 _ -> mkLHsPar x'
867 ; cvtOpApp x'' s y } -- Note [Converting UInfix]
868
869 cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' }
870 cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
871 ; return $ ExprWithTySig (mkLHsSigWcType t') e' }
872 cvt (RecConE c flds) = do { c' <- cNameL c
873 ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
874 ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
875 cvt (RecUpdE e flds) = do { e' <- cvtl e
876 ; flds'
877 <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
878 flds
879 ; return $ mkRdrRecordUpd e' flds' }
880 cvt (StaticE e) = fmap (HsStatic noExt) $ cvtl e
881 cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
882 cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) }
883
884 {- Note [Dropping constructors]
885 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
886 When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
887 we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
888 could meet @UInfix@ constructors containing the @TupE [e]@. For example:
889
890 UInfixE x * (TupE [UInfixE y + z])
891
892 If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
893 and the above expression would be reassociated to
894
895 OpApp (OpApp x * y) + z
896
897 which we don't want.
898 -}
899
900 cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)
901 -> CvtM (LHsRecField' t (LHsExpr GhcPs))
902 cvtFld f (v,e)
903 = do { v' <- vNameL v; e' <- cvtl e
904 ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'
905 , hsRecFieldArg = e'
906 , hsRecPun = False}) }
907
908 cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
909 cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
910 cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
911 cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
912 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
913
914 {- Note [Operator assocation]
915 We must be quite careful about adding parens:
916 * Infix (UInfix ...) op arg Needs parens round the first arg
917 * Infix (Infix ...) op arg Needs parens round the first arg
918 * UInfix (UInfix ...) op arg No parens for first arg
919 * UInfix (Infix ...) op arg Needs parens round first arg
920
921
922 Note [Converting UInfix]
923 ~~~~~~~~~~~~~~~~~~~~~~~~
924 When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust
925 the trees to reflect the fixities of the underlying operators:
926
927 UInfixE x * (UInfixE y + z) ---> (x * y) + z
928
929 This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
930 @mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
931 right-biased for types and left-biased for everything else. So we left-bias the
932 trees of @UInfixP@ and @UInfixE@ and use HsAppsTy for UInfixT.
933
934 Sample input:
935
936 UInfixE
937 (UInfixE x op1 y)
938 op2
939 (UInfixE z op3 w)
940
941 Sample output:
942
943 OpApp
944 (OpApp
945 (OpApp x op1 y)
946 op2
947 z)
948 op3
949 w
950
951 The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
952 biasing.
953 -}
954
955 {- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
956 The produced tree of infix expressions will be left-biased, provided @x@ is.
957
958 We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
959 is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
960 this holds for both branches (of @cvtOpApp@), provided we assume it holds for
961 the recursive calls to @cvtOpApp@.
962
963 When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
964 since we have already run @cvtl@ on it.
965 -}
966 cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)
967 cvtOpApp x op1 (UInfixE y op2 z)
968 = do { l <- wrapL $ cvtOpApp x op1 y
969 ; cvtOpApp l op2 z }
970 cvtOpApp x op y
971 = do { op' <- cvtl op
972 ; y' <- cvtl y
973 ; return (OpApp noExt x op' y') }
974
975 -------------------------------------
976 -- Do notation and statements
977 -------------------------------------
978
979 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
980 cvtHsDo do_or_lc stmts
981 | null stmts = failWith (text "Empty stmt list in do-block")
982 | otherwise
983 = do { stmts' <- cvtStmts stmts
984 ; let Just (stmts'', last') = snocView stmts'
985
986 ; last'' <- case last' of
987 L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
988 _ -> failWith (bad_last last')
989
990 ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
991 where
992 bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
993 , nest 2 $ Outputable.ppr stmt
994 , text "(It should be an expression.)" ]
995
996 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]
997 cvtStmts = mapM cvtStmt
998
999 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
1000 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
1001 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
1002 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds
1003 ; returnL $ LetStmt (noLoc ds') }
1004 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType }
1005 where
1006 cvt_one ds = do { ds' <- cvtStmts ds
1007 ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }
1008
1009 cvtMatch :: HsMatchContext RdrName
1010 -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
1011 cvtMatch ctxt (TH.Match p body decs)
1012 = do { p' <- cvtPat p
1013 ; lp <- case ctxt of
1014 CaseAlt -> return p'
1015 _ -> wrap_conpat p'
1016 ; g' <- cvtGuard body
1017 ; decs' <- cvtLocalDecs (text "a where clause") decs
1018 ; returnL $ Hs.Match ctxt [lp] (GRHSs g' (noLoc decs')) }
1019
1020 cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
1021 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
1022 cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
1023
1024 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
1025 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
1026 ; g' <- returnL $ mkBodyStmt ge'
1027 ; returnL $ GRHS [g'] rhs' }
1028 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
1029 ; returnL $ GRHS gs' rhs' }
1030
1031 cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
1032 cvtOverLit (IntegerL i)
1033 = do { force i; return $ mkHsIntegral (mkIntegralLit i) }
1034 cvtOverLit (RationalL r)
1035 = do { force r; return $ mkHsFractional (mkFractionalLit r) }
1036 cvtOverLit (StringL s)
1037 = do { let { s' = mkFastString s }
1038 ; force s'
1039 ; return $ mkHsIsString (quotedSourceText s) s'
1040 }
1041 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
1042 -- An Integer is like an (overloaded) '3' in a Haskell source program
1043 -- Similarly 3.5 for fractionals
1044
1045 {- Note [Converting strings]
1046 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1047 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
1048 a string literal for "xy". Of course, we might hope to get
1049 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
1050 if it isn't a literal string
1051 -}
1052
1053 allCharLs :: [TH.Exp] -> Maybe String
1054 -- Note [Converting strings]
1055 -- NB: only fire up this setup for a non-empty list, else
1056 -- there's a danger of returning "" for [] :: [Int]!
1057 allCharLs xs
1058 = case xs of
1059 LitE (CharL c) : ys -> go [c] ys
1060 _ -> Nothing
1061 where
1062 go cs [] = Just (reverse cs)
1063 go cs (LitE (CharL c) : ys) = go (c:cs) ys
1064 go _ _ = Nothing
1065
1066 cvtLit :: Lit -> CvtM (HsLit GhcPs)
1067 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i }
1068 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w }
1069 cvtLit (FloatPrimL f)
1070 = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }
1071 cvtLit (DoublePrimL f)
1072 = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }
1073 cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c }
1074 cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c }
1075 cvtLit (StringL s) = do { let { s' = mkFastString s }
1076 ; force s'
1077 ; return $ HsString (quotedSourceText s) s' }
1078 cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
1079 ; force s'
1080 ; return $ HsStringPrim NoSourceText s' }
1081 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
1082 -- cvtLit should not be called on IntegerL, RationalL
1083 -- That precondition is established right here in
1084 -- Convert.hs, hence panic
1085
1086 quotedSourceText :: String -> SourceText
1087 quotedSourceText s = SourceText $ "\"" ++ s ++ "\""
1088
1089 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]
1090 cvtPats pats = mapM cvtPat pats
1091
1092 cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)
1093 cvtPat pat = wrapL (cvtp pat)
1094
1095 cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)
1096 cvtp (TH.LitP l)
1097 | overloadedLit l = do { l' <- cvtOverLit l
1098 ; return (mkNPat (noLoc l') Nothing) }
1099 -- Not right for negative patterns;
1100 -- need to think about that!
1101 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' }
1102 cvtp (TH.VarP s) = do { s' <- vName s
1103 ; return $ Hs.VarPat noExt (noLoc s') }
1104 cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat noExt p' }
1105 -- Note [Dropping constructors]
1106 cvtp (TupP ps) = do { ps' <- cvtPats ps
1107 ; return $ TuplePat noExt ps' Boxed }
1108 cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps
1109 ; return $ TuplePat noExt ps' Unboxed }
1110 cvtp (UnboxedSumP p alt arity)
1111 = do { p' <- cvtPat p
1112 ; unboxedSumChecks alt arity
1113 ; return $ SumPat noExt p' alt arity }
1114 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
1115 ; pps <- mapM wrap_conpat ps'
1116 ; return $ ConPatIn s' (PrefixCon pps) }
1117 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
1118 ; wrapParL (ParPat noExt) $
1119 ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
1120 -- See Note [Operator association]
1121 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
1122 cvtp (ParensP p) = do { p' <- cvtPat p;
1123 ; case p' of -- may be wrapped ConPatIn
1124 (L _ (ParPat {})) -> return $ unLoc p'
1125 _ -> return $ ParPat noExt p' }
1126 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExt p' }
1127 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExt p' }
1128 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p
1129 ; return $ AsPat noExt s' p' }
1130 cvtp TH.WildP = return $ WildPat noExt
1131 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
1132 ; return $ ConPatIn c'
1133 $ Hs.RecCon (HsRecFields fs' Nothing) }
1134 cvtp (ListP ps) = do { ps' <- cvtPats ps
1135 ; return
1136 $ ListPat noExt ps' placeHolderType Nothing }
1137 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
1138 ; return $ SigPat (mkLHsSigWcType t') p' }
1139 cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
1140 ; return $ ViewPat noExt e' p'}
1141
1142 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
1143 cvtPatFld (s,p)
1144 = do { L ls s' <- vNameL s; p' <- cvtPat p
1145 ; return (noLoc $ HsRecField { hsRecFieldLbl
1146 = L ls $ mkFieldOcc (L ls s')
1147 , hsRecFieldArg = p'
1148 , hsRecPun = False}) }
1149
1150 wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs)
1151 wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat noExt p
1152 wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p
1153 wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat noExt p
1154 wrap_conpat p = return p
1155
1156 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
1157 The produced tree of infix patterns will be left-biased, provided @x@ is.
1158
1159 See the @cvtOpApp@ documentation for how this function works.
1160 -}
1161 cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)
1162 cvtOpAppP x op1 (UInfixP y op2 z)
1163 = do { l <- wrapL $ cvtOpAppP x op1 y
1164 ; cvtOpAppP l op2 z }
1165 cvtOpAppP x op y
1166 = do { op' <- cNameL op
1167 ; y' <- cvtPat y
1168 ; return (ConPatIn op' (InfixCon x y')) }
1169
1170 -----------------------------------------------------------
1171 -- Types and type variables
1172
1173 cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs)
1174 cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
1175
1176 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
1177 cvt_tv (TH.PlainTV nm)
1178 = do { nm' <- tNameL nm
1179 ; returnL $ UserTyVar noExt nm' }
1180 cvt_tv (TH.KindedTV nm ki)
1181 = do { nm' <- tNameL nm
1182 ; ki' <- cvtKind ki
1183 ; returnL $ KindedTyVar noExt nm' ki' }
1184
1185 cvtRole :: TH.Role -> Maybe Coercion.Role
1186 cvtRole TH.NominalR = Just Coercion.Nominal
1187 cvtRole TH.RepresentationalR = Just Coercion.Representational
1188 cvtRole TH.PhantomR = Just Coercion.Phantom
1189 cvtRole TH.InferR = Nothing
1190
1191 cvtContext :: TH.Cxt -> CvtM (LHsContext GhcPs)
1192 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
1193
1194 cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
1195 cvtPred = cvtType
1196
1197 cvtDerivClause :: TH.DerivClause
1198 -> CvtM (LHsDerivingClause GhcPs)
1199 cvtDerivClause (TH.DerivClause ds ctxt)
1200 = do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt
1201 ; let ds' = fmap (L loc . cvtDerivStrategy) ds
1202 ; returnL $ HsDerivingClause ds' ctxt' }
1203
1204 cvtDerivStrategy :: TH.DerivStrategy -> Hs.DerivStrategy
1205 cvtDerivStrategy TH.StockStrategy = Hs.StockStrategy
1206 cvtDerivStrategy TH.AnyclassStrategy = Hs.AnyclassStrategy
1207 cvtDerivStrategy TH.NewtypeStrategy = Hs.NewtypeStrategy
1208
1209 cvtType :: TH.Type -> CvtM (LHsType GhcPs)
1210 cvtType = cvtTypeKind "type"
1211
1212 cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)
1213 cvtTypeKind ty_str ty
1214 = do { (head_ty, tys') <- split_ty_app ty
1215 ; case head_ty of
1216 TupleT n
1217 | tys' `lengthIs` n -- Saturated
1218 -> if n==1 then return (head tys') -- Singleton tuples treated
1219 -- like nothing (ie just parens)
1220 else returnL (HsTupleTy noExt
1221 HsBoxedOrConstraintTuple tys')
1222 | n == 1
1223 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
1224 | otherwise
1225 -> mk_apps (HsTyVar noExt NotPromoted
1226 (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
1227 UnboxedTupleT n
1228 | tys' `lengthIs` n -- Saturated
1229 -> returnL (HsTupleTy noExt HsUnboxedTuple tys')
1230 | otherwise
1231 -> mk_apps (HsTyVar noExt NotPromoted
1232 (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'
1233 UnboxedSumT n
1234 | n < 2
1235 -> failWith $
1236 vcat [ text "Illegal sum arity:" <+> text (show n)
1237 , nest 2 $
1238 text "Sums must have an arity of at least 2" ]
1239 | tys' `lengthIs` n -- Saturated
1240 -> returnL (HsSumTy noExt tys')
1241 | otherwise
1242 -> mk_apps (HsTyVar noExt NotPromoted
1243 (noLoc (getRdrName (sumTyCon n))))
1244 tys'
1245 ArrowT
1246 | [x',y'] <- tys' -> do
1247 case x' of
1248 (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy noExt x')
1249 ; returnL (HsFunTy noExt x'' y') }
1250 _ -> returnL (HsFunTy noExt x' y')
1251 | otherwise ->
1252 mk_apps (HsTyVar noExt NotPromoted
1253 (noLoc (getRdrName funTyCon)))
1254 tys'
1255 ListT
1256 | [x'] <- tys' -> returnL (HsListTy noExt x')
1257 | otherwise ->
1258 mk_apps (HsTyVar noExt NotPromoted
1259 (noLoc (getRdrName listTyCon)))
1260 tys'
1261 VarT nm -> do { nm' <- tNameL nm
1262 ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
1263 ConT nm -> do { nm' <- tconName nm
1264 ; mk_apps (HsTyVar noExt NotPromoted (noLoc nm')) tys'}
1265
1266 ForallT tvs cxt ty
1267 | null tys'
1268 -> do { tvs' <- cvtTvs tvs
1269 ; cxt' <- cvtContext cxt
1270 ; ty' <- cvtType ty
1271 ; loc <- getL
1272 ; let hs_ty = mkHsForAllTy tvs loc tvs' rho_ty
1273 rho_ty = mkHsQualTy cxt loc cxt' ty'
1274
1275 ; return hs_ty }
1276
1277 SigT ty ki
1278 -> do { ty' <- cvtType ty
1279 ; ki' <- cvtKind ki
1280 ; mk_apps (HsKindSig noExt ty' ki') tys'
1281 }
1282
1283 LitT lit
1284 -> returnL (HsTyLit noExt (cvtTyLit lit))
1285
1286 WildCardT
1287 -> mk_apps mkAnonWildCardTy tys'
1288
1289 InfixT t1 s t2
1290 -> do { s' <- tconName s
1291 ; t1' <- cvtType t1
1292 ; t2' <- cvtType t2
1293 ; mk_apps (HsTyVar noExt NotPromoted (noLoc s')) [t1', t2']
1294 }
1295
1296 UInfixT t1 s t2
1297 -> do { t1' <- cvtType t1
1298 ; t2' <- cvtType t2
1299 ; s' <- tconName s
1300 ; return $ cvtOpAppT t1' s' t2'
1301 } -- Note [Converting UInfix]
1302
1303 ParensT t
1304 -> do { t' <- cvtType t
1305 ; returnL $ HsParTy noExt t'
1306 }
1307
1308 PromotedT nm -> do { nm' <- cName nm
1309 ; mk_apps (HsTyVar noExt NotPromoted
1310 (noLoc nm')) tys' }
1311 -- Promoted data constructor; hence cName
1312
1313 PromotedTupleT n
1314 | n == 1
1315 -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
1316 | m == n -- Saturated
1317 -> returnL (HsExplicitTupleTy noExt tys')
1318 where
1319 m = length tys'
1320
1321 PromotedNilT
1322 -> returnL (HsExplicitListTy noExt Promoted [])
1323
1324 PromotedConsT -- See Note [Representing concrete syntax in types]
1325 -- in Language.Haskell.TH.Syntax
1326 | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys'
1327 -> returnL (HsExplicitListTy noExt ip (ty1:tys2))
1328 | otherwise
1329 -> mk_apps (HsTyVar noExt NotPromoted
1330 (noLoc (getRdrName consDataCon)))
1331 tys'
1332
1333 StarT
1334 -> returnL (HsTyVar noExt NotPromoted (noLoc
1335 (getRdrName liftedTypeKindTyCon)))
1336
1337 ConstraintT
1338 -> returnL (HsTyVar noExt NotPromoted
1339 (noLoc (getRdrName constraintKindTyCon)))
1340
1341 EqualityT
1342 | [x',y'] <- tys' -> returnL (HsEqTy noExt x' y')
1343 | otherwise ->
1344 mk_apps (HsTyVar noExt NotPromoted
1345 (noLoc (getRdrName eqPrimTyCon))) tys'
1346
1347 _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
1348 }
1349
1350 -- | Constructs an application of a type to arguments passed in a list.
1351 mk_apps :: HsType GhcPs -> [LHsType GhcPs] -> CvtM (LHsType GhcPs)
1352 mk_apps head_ty [] = returnL head_ty
1353 mk_apps head_ty (ty:tys) =
1354 do { head_ty' <- returnL head_ty
1355 ; p_ty <- add_parens ty
1356 ; mk_apps (HsAppTy noExt head_ty' p_ty) tys }
1357 where
1358 -- See Note [Adding parens for splices]
1359 add_parens t
1360 | isCompoundHsType t = returnL (HsParTy noExt t)
1361 | otherwise = return t
1362
1363 wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs)
1364 wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t)
1365 wrap_apps t = return t
1366
1367 -- ---------------------------------------------------------------------
1368 -- Note [Adding parens for splices]
1369 {-
1370 The hsSyn representation of parsed source explicitly contains all the original
1371 parens, as written in the source.
1372
1373 When a Template Haskell (TH) splice is evaluated, the original splice is first
1374 renamed and type checked and then finally converted to core in DsMeta. This core
1375 is then run in the TH engine, and the result comes back as a TH AST.
1376
1377 In the process, all parens are stripped out, as they are not needed.
1378
1379 This Convert module then converts the TH AST back to hsSyn AST.
1380
1381 In order to pretty-print this hsSyn AST, parens need to be adde back at certain
1382 points so that the code is readable with its original meaning.
1383
1384 So scattered through Convert.hs are various points where parens are added.
1385
1386 See (among other closed issued) https://ghc.haskell.org/trac/ghc/ticket/14289
1387 -}
1388 -- ---------------------------------------------------------------------
1389
1390 -- | Constructs an arrow type with a specified return type
1391 mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
1392 mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
1393 where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
1394 go arg ret_ty = do { ret_ty_l <- returnL ret_ty
1395 ; return (HsFunTy noExt arg ret_ty_l) }
1396
1397 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs])
1398 split_ty_app ty = go ty []
1399 where
1400 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
1401 go f as = return (f,as)
1402
1403 cvtTyLit :: TH.TyLit -> HsTyLit
1404 cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
1405 cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
1406
1407 {- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy
1408 structure in them.
1409 -}
1410 cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs
1411 cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
1412 = L (combineSrcSpans loc1 loc2) $
1413 HsAppsTy noExt (t1' ++ [noLoc $ HsAppInfix noExt (noLoc op)] ++ t2')
1414 where
1415 t1' | L _ (HsAppsTy _ t1s) <- t1
1416 = t1s
1417 | otherwise
1418 = [noLoc $ HsAppPrefix noExt t1]
1419
1420 t2' | L _ (HsAppsTy _ t2s) <- t2
1421 = t2s
1422 | otherwise
1423 = [noLoc $ HsAppPrefix noExt t2]
1424
1425 cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
1426 cvtKind = cvtTypeKind "kind"
1427
1428 -- | Convert Maybe Kind to a type family result signature. Used with data
1429 -- families where naming of the result is not possible (thus only kind or no
1430 -- signature is possible).
1431 cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
1432 -> CvtM (LFamilyResultSig GhcPs)
1433 cvtMaybeKindToFamilyResultSig Nothing = returnL Hs.NoSig
1434 cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
1435 ; returnL (Hs.KindSig ki') }
1436
1437 -- | Convert type family result signature. Used with both open and closed type
1438 -- families.
1439 cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
1440 cvtFamilyResultSig TH.NoSig = returnL Hs.NoSig
1441 cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki
1442 ; returnL (Hs.KindSig ki') }
1443 cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
1444 ; returnL (Hs.TyVarSig tv) }
1445
1446 -- | Convert injectivity annotation of a type family.
1447 cvtInjectivityAnnotation :: TH.InjectivityAnn
1448 -> CvtM (Hs.LInjectivityAnn GhcPs)
1449 cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
1450 = do { annLHS' <- tNameL annLHS
1451 ; annRHS' <- mapM tNameL annRHS
1452 ; returnL (Hs.InjectivityAnn annLHS' annRHS') }
1453
1454 cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)
1455 -- pattern synonym types are of peculiar shapes, which is why we treat
1456 -- them separately from regular types;
1457 -- see Note [Pattern synonym type signatures and Template Haskell]
1458 cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
1459 | null exis, null provs = cvtType (ForallT univs reqs ty)
1460 | null univs, null reqs = do { l <- getL
1461 ; ty' <- cvtType (ForallT exis provs ty)
1462 ; return $ L l (HsQualTy { hst_ctxt = L l []
1463 , hst_xqual = noExt
1464 , hst_body = ty' }) }
1465 | null reqs = do { l <- getL
1466 ; univs' <- hsQTvExplicit <$> cvtTvs univs
1467 ; ty' <- cvtType (ForallT exis provs ty)
1468 ; let forTy = HsForAllTy { hst_bndrs = univs'
1469 , hst_xforall = noExt
1470 , hst_body = L l cxtTy }
1471 cxtTy = HsQualTy { hst_ctxt = L l []
1472 , hst_xqual = noExt
1473 , hst_body = ty' }
1474 ; return $ L l forTy }
1475 | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))
1476 cvtPatSynSigTy ty = cvtType ty
1477
1478 -----------------------------------------------------------
1479 cvtFixity :: TH.Fixity -> Hs.Fixity
1480 cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)
1481 where
1482 cvt_dir TH.InfixL = Hs.InfixL
1483 cvt_dir TH.InfixR = Hs.InfixR
1484 cvt_dir TH.InfixN = Hs.InfixN
1485
1486 -----------------------------------------------------------
1487
1488
1489 -----------------------------------------------------------
1490 -- some useful things
1491
1492 overloadedLit :: Lit -> Bool
1493 -- True for literals that Haskell treats as overloaded
1494 overloadedLit (IntegerL _) = True
1495 overloadedLit (RationalL _) = True
1496 overloadedLit _ = False
1497
1498 -- Checks that are performed when converting unboxed sum expressions and
1499 -- patterns alike.
1500 unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
1501 unboxedSumChecks alt arity
1502 | alt > arity
1503 = failWith $ text "Sum alternative" <+> text (show alt)
1504 <+> text "exceeds its arity," <+> text (show arity)
1505 | alt <= 0
1506 = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)
1507 , nest 2 $ text "Sum alternatives must start from 1" ]
1508 | arity < 2
1509 = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)
1510 , nest 2 $ text "Sums must have an arity of at least 2" ]
1511 | otherwise
1512 = return ()
1513
1514 -- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the
1515 -- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'
1516 -- using the provided 'LHsQTyVars' and 'LHsType'.
1517 mkHsForAllTy :: [TH.TyVarBndr]
1518 -- ^ The original Template Haskell type variable binders
1519 -> SrcSpan
1520 -- ^ The location of the returned 'LHsType' if it needs an
1521 -- explicit forall
1522 -> LHsQTyVars GhcPs
1523 -- ^ The converted type variable binders
1524 -> LHsType GhcPs
1525 -- ^ The converted rho type
1526 -> LHsType GhcPs
1527 -- ^ The complete type, quantified with a forall if necessary
1528 mkHsForAllTy tvs loc tvs' rho_ty
1529 | null tvs = rho_ty
1530 | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
1531 , hst_xforall = noExt
1532 , hst_body = rho_ty }
1533
1534 -- | If passed an empty 'TH.Cxt', this simply returns the third argument
1535 -- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
1536 -- 'LHsContext' and 'LHsType'.
1537
1538 -- It's important that we don't build an HsQualTy if the context is empty,
1539 -- as the pretty-printer for HsType _always_ prints contexts, even if
1540 -- they're empty. See Trac #13183.
1541 mkHsQualTy :: TH.Cxt
1542 -- ^ The original Template Haskell context
1543 -> SrcSpan
1544 -- ^ The location of the returned 'LHsType' if it needs an
1545 -- explicit context
1546 -> LHsContext GhcPs
1547 -- ^ The converted context
1548 -> LHsType GhcPs
1549 -- ^ The converted tau type
1550 -> LHsType GhcPs
1551 -- ^ The complete type, qualified with a context if necessary
1552 mkHsQualTy ctxt loc ctxt' ty
1553 | null ctxt = ty
1554 | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
1555 , hst_body = ty }
1556
1557 --------------------------------------------------------------------
1558 -- Turning Name back into RdrName
1559 --------------------------------------------------------------------
1560
1561 -- variable names
1562 vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
1563 vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName
1564
1565 -- Variable names
1566 vNameL n = wrapL (vName n)
1567 vName n = cvtName OccName.varName n
1568
1569 -- Constructor function names; this is Haskell source, hence srcDataName
1570 cNameL n = wrapL (cName n)
1571 cName n = cvtName OccName.dataName n
1572
1573 -- Variable *or* constructor names; check by looking at the first char
1574 vcNameL n = wrapL (vcName n)
1575 vcName n = if isVarName n then vName n else cName n
1576
1577 -- Type variable names
1578 tNameL n = wrapL (tName n)
1579 tName n = cvtName OccName.tvName n
1580
1581 -- Type Constructor names
1582 tconNameL n = wrapL (tconName n)
1583 tconName n = cvtName OccName.tcClsName n
1584
1585 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
1586 cvtName ctxt_ns (TH.Name occ flavour)
1587 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
1588 | otherwise
1589 = do { loc <- getL
1590 ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
1591 ; force rdr_name
1592 ; return rdr_name }
1593 where
1594 occ_str = TH.occString occ
1595
1596 okOcc :: OccName.NameSpace -> String -> Bool
1597 okOcc ns str
1598 | OccName.isVarNameSpace ns = okVarOcc str
1599 | OccName.isDataConNameSpace ns = okConOcc str
1600 | otherwise = okTcOcc str
1601
1602 -- Determine the name space of a name in a type
1603 --
1604 isVarName :: TH.Name -> Bool
1605 isVarName (TH.Name occ _)
1606 = case TH.occString occ of
1607 "" -> False
1608 (c:_) -> startsVarId c || startsVarSym c
1609
1610 badOcc :: OccName.NameSpace -> String -> SDoc
1611 badOcc ctxt_ns occ
1612 = text "Illegal" <+> pprNameSpace ctxt_ns
1613 <+> text "name:" <+> quotes (text occ)
1614
1615 thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
1616 -- This turns a TH Name into a RdrName; used for both binders and occurrences
1617 -- See Note [Binders in Template Haskell]
1618 -- The passed-in name space tells what the context is expecting;
1619 -- use it unless the TH name knows what name-space it comes
1620 -- from, in which case use the latter
1621 --
1622 -- We pass in a SrcSpan (gotten from the monad) because this function
1623 -- is used for *binders* and if we make an Exact Name we want it
1624 -- to have a binding site inside it. (cf Trac #5434)
1625 --
1626 -- ToDo: we may generate silly RdrNames, by passing a name space
1627 -- that doesn't match the string, like VarName ":+",
1628 -- which will give confusing error messages later
1629 --
1630 -- The strict applications ensure that any buried exceptions get forced
1631 thRdrName loc ctxt_ns th_occ th_name
1632 = case th_name of
1633 TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
1634 TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ
1635 TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
1636 TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
1637 TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
1638 | otherwise -> mkRdrUnqual $! occ
1639 -- We check for built-in syntax here, because the TH
1640 -- user might have written a (NameS "(,,)"), for example
1641 where
1642 occ :: OccName.OccName
1643 occ = mk_occ ctxt_ns th_occ
1644
1645 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
1646 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
1647
1648 thRdrNameGuesses :: TH.Name -> [RdrName]
1649 thRdrNameGuesses (TH.Name occ flavour)
1650 -- This special case for NameG ensures that we don't generate duplicates in the output list
1651 | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
1652 | otherwise = [ thRdrName noSrcSpan gns occ_str flavour
1653 | gns <- guessed_nss]
1654 where
1655 -- guessed_ns are the name spaces guessed from looking at the TH name
1656 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
1657 | otherwise = [OccName.varName, OccName.tvName]
1658 occ_str = TH.occString occ
1659
1660 -- The packing and unpacking is rather turgid :-(
1661 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
1662 mk_occ ns occ = OccName.mkOccName ns occ
1663
1664 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
1665 mk_ghc_ns TH.DataName = OccName.dataName
1666 mk_ghc_ns TH.TcClsName = OccName.tcClsName
1667 mk_ghc_ns TH.VarName = OccName.varName
1668
1669 mk_mod :: TH.ModName -> ModuleName
1670 mk_mod mod = mkModuleName (TH.modString mod)
1671
1672 mk_pkg :: TH.PkgName -> UnitId
1673 mk_pkg pkg = stringToUnitId (TH.pkgString pkg)
1674
1675 mk_uniq :: Int -> Unique
1676 mk_uniq u = mkUniqueGrimily u
1677
1678 {-
1679 Note [Binders in Template Haskell]
1680 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1681 Consider this TH term construction:
1682 do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name
1683 ; x2 <- TH.newName "x" -- Builds a NameU
1684 ; x3 <- TH.newName "x"
1685
1686 ; let x = mkName "x" -- mkName :: String -> TH.Name
1687 -- Builds a NameS
1688
1689 ; return (LamE (..pattern [x1,x2]..) $
1690 LamE (VarPat x3) $
1691 ..tuple (x1,x2,x3,x)) }
1692
1693 It represents the term \[x1,x2]. \x3. (x1,x2,x3,x)
1694
1695 a) We don't want to complain about "x" being bound twice in
1696 the pattern [x1,x2]
1697 b) We don't want x3 to shadow the x1,x2
1698 c) We *do* want 'x' (dynamically bound with mkName) to bind
1699 to the innermost binding of "x", namely x3.
1700 d) When pretty printing, we want to print a unique with x1,x2
1701 etc, else they'll all print as "x" which isn't very helpful
1702
1703 When we convert all this to HsSyn, the TH.Names are converted with
1704 thRdrName. To achieve (b) we want the binders to be Exact RdrNames.
1705 Achieving (a) is a bit awkward, because
1706 - We must check for duplicate and shadowed names on Names,
1707 not RdrNames, *after* renaming.
1708 See Note [Collect binders only after renaming] in HsUtils
1709
1710 - But to achieve (a) we must distinguish between the Exact
1711 RdrNames arising from TH and the Unqual RdrNames that would
1712 come from a user writing \[x,x] -> blah
1713
1714 So in Convert.thRdrName we translate
1715 TH Name RdrName
1716 --------------------------------------------------------
1717 NameU (arising from newName) --> Exact (Name{ System })
1718 NameS (arising from mkName) --> Unqual
1719
1720 Notice that the NameUs generate *System* Names. Then, when
1721 figuring out shadowing and duplicates, we can filter out
1722 System Names.
1723
1724 This use of System Names fits with other uses of System Names, eg for
1725 temporary variables "a". Since there are lots of things called "a" we
1726 usually want to print the name with the unique, and that is indeed
1727 the way System Names are printed.
1728
1729 There's a small complication of course; see Note [Looking up Exact
1730 RdrNames] in RnEnv.
1731 -}
1732
1733 {-
1734 Note [Pattern synonym type signatures and Template Haskell]
1735 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1736
1737 In general, the type signature of a pattern synonym
1738
1739 pattern P x1 x2 .. xn = <some-pattern>
1740
1741 is of the form
1742
1743 forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
1744
1745 with the following parts:
1746
1747 1) the (possibly empty lists of) universally quantified type
1748 variables `univs` and required constraints `reqs` on them.
1749 2) the (possibly empty lists of) existentially quantified type
1750 variables `exis` and the provided constraints `provs` on them.
1751 3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,
1752 x2, .., xn, respectively
1753 4) the type `t` of <some-pattern>, mentioning only universals from `univs`.
1754
1755 Due to the two forall quantifiers and constraint contexts (either of
1756 which might be empty), pattern synonym type signatures are treated
1757 specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and
1758 `typecheck/TcSplice.hs`:
1759
1760 (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
1761 `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:
1762
1763 ForallT univs reqs (ForallT exis provs ty)
1764 (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
1765
1766 (b) When converting pattern synonyms from TH.Dec to HsSyn in
1767 `hsSyn/Convert.hs`, we convert their TH type signatures back to an
1768 appropriate Haskell pattern synonym type of the form
1769
1770 forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
1771
1772 where initial empty `univs` type variables or an empty `reqs`
1773 constraint context are represented *explicitly* as `() =>`.
1774
1775 (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always
1776 return its *full* type, i.e.:
1777
1778 ForallT univs reqs (ForallT exis provs ty)
1779 (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
1780
1781 The key point is to always represent a pattern synonym's *full* type
1782 in cases (a) and (c) to make it clear which of the two forall
1783 quantifiers and/or constraint contexts are specified, and which are
1784 not. See GHC's user's guide on pattern synonyms for more information
1785 about pattern synonym type signatures.
1786
1787 -}