Fold integer-gmp.git into ghc.git (re #8545)
[ghc.git] / compiler / hsSyn / Convert.lhs
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 \begin{code}
9 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
10                 convertToHsType,
11                 thRdrNameGuesses ) where
12
13 import HsSyn as Hs
14 import qualified Class
15 import RdrName
16 import qualified Name
17 import Module
18 import RdrHsSyn
19 import qualified OccName
20 import OccName
21 import SrcLoc
22 import Type
23 import qualified Coercion ( Role(..) )
24 import TysWiredIn
25 import TysPrim (eqPrimTyCon)
26 import BasicTypes as Hs
27 import ForeignCall
28 import Unique
29 import ErrUtils
30 import Bag
31 import Util
32 import FastString
33 import Outputable
34
35 import qualified Data.ByteString as BS
36 import Control.Monad( unless, liftM, ap )
37 import Control.Applicative (Applicative(..))
38
39 import Language.Haskell.TH as TH hiding (sigP)
40 import Language.Haskell.TH.Syntax as TH
41 import GHC.Exts
42
43 -------------------------------------------------------------------
44 --              The external interface
45
46 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName]
47 convertToHsDecls loc ds = initCvt loc (mapM cvt_dec ds)
48   where
49     cvt_dec d = wrapMsg "declaration" d (cvtDec d)
50
51 convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName)
52 convertToHsExpr loc e
53   = initCvt loc $ wrapMsg "expression" e $ cvtl e
54
55 convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName)
56 convertToPat loc p
57   = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
58
59 convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName)
60 convertToHsType loc t
61   = initCvt loc $ wrapMsg "type" t $ cvtType t
62
63 -------------------------------------------------------------------
64 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc a }
65         -- Push down the source location;
66         -- Can fail, with a single error message
67
68 -- NB: If the conversion succeeds with (Right x), there should
69 --     be no exception values hiding in x
70 -- Reason: so a (head []) in TH code doesn't subsequently
71 --         make GHC crash when it tries to walk the generated tree
72
73 -- Use the loc everywhere, for lack of anything better
74 -- In particular, we want it on binding locations, so that variables bound in
75 -- the spliced-in declarations get a location that at least relates to the splice point
76
77 instance Functor CvtM where
78     fmap = liftM
79
80 instance Applicative CvtM where
81     pure = return
82     (<*>) = ap
83
84 instance Monad CvtM where
85   return x       = CvtM $ \_   -> Right x
86   (CvtM m) >>= k = CvtM $ \loc -> case m loc of
87                                   Left err -> Left err
88                                   Right v  -> unCvtM (k v) loc
89
90 initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
91 initCvt loc (CvtM m) = m loc
92
93 force :: a -> CvtM ()
94 force a = a `seq` return ()
95
96 failWith :: MsgDoc -> CvtM a
97 failWith m = CvtM (\_ -> Left m)
98
99 getL :: CvtM SrcSpan
100 getL = CvtM (\loc -> Right loc)
101
102 returnL :: a -> CvtM (Located a)
103 returnL x = CvtM (\loc -> Right (L loc x))
104
105 wrapParL :: (Located a -> a) -> a -> CvtM a
106 wrapParL add_par x = CvtM (\loc -> Right (add_par (L loc x)))
107
108 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
109 -- E.g  wrapMsg "declaration" dec thing
110 wrapMsg what item (CvtM m)
111   = CvtM (\loc -> case m loc of
112                      Left err -> Left (err $$ getPprStyle msg)
113                      Right v  -> Right v)
114   where
115         -- Show the item in pretty syntax normally,
116         -- but with all its constructors if you say -dppr-debug
117     msg sty = hang (ptext (sLit "When splicing a TH") <+> text what <> colon)
118                  2 (if debugStyle sty
119                     then text (show item)
120                     else text (pprint item))
121
122 wrapL :: CvtM a -> CvtM (Located a)
123 wrapL (CvtM m) = CvtM (\loc -> case m loc of
124                                Left err -> Left err
125                                Right v  -> Right (L loc v))
126
127 -------------------------------------------------------------------
128 cvtDec :: TH.Dec -> CvtM (LHsDecl RdrName)
129 cvtDec (TH.ValD pat body ds)
130   | TH.VarP s <- pat
131   = do  { s' <- vNameL s
132         ; cl' <- cvtClause (Clause [] body ds)
133         ; returnL $ Hs.ValD $ mkFunBind s' [cl'] }
134
135   | otherwise
136   = do  { pat' <- cvtPat pat
137         ; body' <- cvtGuard body
138         ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds
139         ; returnL $ Hs.ValD $
140           PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds'
141                   , pat_rhs_ty = void, bind_fvs = placeHolderNames
142                   , pat_ticks = (Nothing,[]) } }
143
144 cvtDec (TH.FunD nm cls)
145   | null cls
146   = failWith (ptext (sLit "Function binding for")
147                  <+> quotes (text (TH.pprint nm))
148                  <+> ptext (sLit "has no equations"))
149   | otherwise
150   = do  { nm' <- vNameL nm
151         ; cls' <- mapM cvtClause cls
152         ; returnL $ Hs.ValD $ mkFunBind nm' cls' }
153
154 cvtDec (TH.SigD nm typ)
155   = do  { nm' <- vNameL nm
156         ; ty' <- cvtType typ
157         ; returnL $ Hs.SigD (TypeSig [nm'] ty') }
158
159 cvtDec (TH.InfixD fx nm)
160   = do { nm' <- vNameL nm
161        ; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
162
163 cvtDec (PragmaD prag)
164   = cvtPragmaD prag
165
166 cvtDec (TySynD tc tvs rhs)
167   = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
168         ; rhs' <- cvtType rhs
169         ; returnL $ TyClD (SynDecl { tcdLName = tc'
170                                   , tcdTyVars = tvs', tcdFVs = placeHolderNames
171                                   , tcdRhs = rhs' }) }
172
173 cvtDec (DataD ctxt tc tvs constrs derivs)
174   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
175         ; cons' <- mapM cvtConstr constrs
176         ; derivs' <- cvtDerivs derivs
177         ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
178                                 , dd_ctxt = ctxt'
179                                 , dd_kindSig = Nothing
180                                 , dd_cons = cons', dd_derivs = derivs' }
181         ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
182                                     , tcdDataDefn = defn, tcdFVs = placeHolderNames }) }
183
184 cvtDec (NewtypeD ctxt tc tvs constr derivs)
185   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
186         ; con' <- cvtConstr constr
187         ; derivs' <- cvtDerivs derivs
188         ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
189                                 , dd_ctxt = ctxt'
190                                 , dd_kindSig = Nothing
191                                 , dd_cons = [con'], dd_derivs = derivs' }
192         ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
193                                     , tcdDataDefn = defn, tcdFVs = placeHolderNames }) }
194
195 cvtDec (ClassD ctxt cl tvs fds decs)
196   = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
197         ; fds'  <- mapM cvt_fundep fds
198         ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
199         ; unless (null adts')
200             (failWith $ (ptext (sLit "Default data instance declarations are not allowed:"))
201                    $$ (Outputable.ppr adts'))
202         ; returnL $ TyClD $
203           ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
204                     , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
205                     , tcdATs = fams', tcdATDefs = ats', tcdDocs = []
206                     , tcdFVs = placeHolderNames }
207                               -- no docs in TH ^^
208         }
209
210 cvtDec (InstanceD ctxt ty decs)
211   = do  { let doc = ptext (sLit "an instance declaration")
212         ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
213         ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
214         ; ctxt' <- cvtContext ctxt
215         ; L loc ty' <- cvtType ty
216         ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
217         ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts')) }
218
219 cvtDec (ForeignD ford)
220   = do { ford' <- cvtForD ford
221        ; returnL $ ForD ford' }
222
223 cvtDec (FamilyD flav tc tvs kind)
224   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
225        ; kind' <- cvtMaybeKind kind
226        ; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) }
227   where
228     cvtFamFlavour TypeFam = OpenTypeFamily
229     cvtFamFlavour DataFam = DataFamily
230
231 cvtDec (DataInstD ctxt tc tys constrs derivs)
232   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
233        ; cons' <- mapM cvtConstr constrs
234        ; derivs' <- cvtDerivs derivs
235        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
236                                , dd_ctxt = ctxt'
237                                , dd_kindSig = Nothing
238                                , dd_cons = cons', dd_derivs = derivs' }
239
240        ; returnL $ InstD $ DataFamInstD
241            { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
242                                          , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
243
244 cvtDec (NewtypeInstD ctxt tc tys constr derivs)
245   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
246        ; con' <- cvtConstr constr
247        ; derivs' <- cvtDerivs derivs
248        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
249                                , dd_ctxt = ctxt'
250                                , dd_kindSig = Nothing
251                                , dd_cons = [con'], dd_derivs = derivs' }
252        ; returnL $ InstD $ DataFamInstD
253            { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
254                                          , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
255
256 cvtDec (TySynInstD tc eqn)
257   = do  { tc' <- tconNameL tc
258         ; eqn' <- cvtTySynEqn tc' eqn
259         ; returnL $ InstD $ TyFamInstD
260             { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
261                                         , tfid_fvs = placeHolderNames } } }
262
263 cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
264   | not $ null eqns
265   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars
266        ; mkind' <- cvtMaybeKind mkind
267        ; eqns' <- mapM (cvtTySynEqn tc') eqns
268        ; returnL $ TyClD (FamDecl (FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind')) }
269   | otherwise
270   = failWith (ptext (sLit "Illegal empty closed type family"))
271
272 cvtDec (TH.RoleAnnotD tc roles)
273   = do { tc' <- tconNameL tc
274        ; let roles' = map (noLoc . cvtRole) roles
275        ; returnL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
276 ----------------
277 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
278 cvtTySynEqn tc (TySynEqn lhs rhs)
279   = do  { lhs' <- mapM cvtType lhs
280         ; rhs' <- cvtType rhs
281         ; returnL $ TyFamInstEqn { tfie_tycon = tc
282                                  , tfie_pats = mkHsWithBndrs lhs'
283                                  , tfie_rhs = rhs' } }
284
285 ----------------
286 cvt_ci_decs :: MsgDoc -> [TH.Dec]
287             -> CvtM (LHsBinds RdrName,
288                      [LSig RdrName],
289                      [LFamilyDecl RdrName],
290                      [LTyFamInstDecl RdrName],
291                      [LDataFamInstDecl RdrName])
292 -- Convert the declarations inside a class or instance decl
293 -- ie signatures, bindings, and associated types
294 cvt_ci_decs doc decs
295   = do  { decs' <- mapM cvtDec decs
296         ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
297         ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'
298         ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'
299         ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
300         ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
301         ; unless (null bads) (failWith (mkBadDecMsg doc bads))
302           --We use FromSource as the origin of the bind
303           -- because the TH declaration is user-written
304         ; return (listToBag binds', sigs', fams', ats', adts') }
305
306 ----------------
307 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
308              -> CvtM ( LHsContext RdrName
309                      , Located RdrName
310                      , LHsTyVarBndrs RdrName)
311 cvt_tycl_hdr cxt tc tvs
312   = do { cxt' <- cvtContext cxt
313        ; tc'  <- tconNameL tc
314        ; tvs' <- cvtTvs tvs
315        ; return (cxt', tc', tvs')
316        }
317
318 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
319                -> CvtM ( LHsContext RdrName
320                        , Located RdrName
321                        , HsWithBndrs [LHsType RdrName])
322 cvt_tyinst_hdr cxt tc tys
323   = do { cxt' <- cvtContext cxt
324        ; tc'  <- tconNameL tc
325        ; tys' <- mapM cvtType tys
326        ; return (cxt', tc', mkHsWithBndrs tys') }
327
328 -------------------------------------------------------------------
329 --              Partitioning declarations
330 -------------------------------------------------------------------
331
332 is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
333 is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
334 is_fam_decl decl = Right decl
335
336 is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName)
337 is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
338 is_tyfam_inst decl                                              = Right decl
339
340 is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName)
341 is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
342 is_datafam_inst decl                                                = Right decl
343
344 is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
345 is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
346 is_sig decl                  = Right decl
347
348 is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
349 is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
350 is_bind decl                   = Right decl
351
352 mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
353 mkBadDecMsg doc bads
354   = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
355         , nest 2 (vcat (map Outputable.ppr bads)) ]
356
357 ---------------------------------------------------
358 --      Data types
359 -- Can't handle GADTs yet
360 ---------------------------------------------------
361
362 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
363
364 cvtConstr (NormalC c strtys)
365   = do  { c'   <- cNameL c
366         ; cxt' <- returnL []
367         ; tys' <- mapM cvt_arg strtys
368         ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
369
370 cvtConstr (RecC c varstrtys)
371   = do  { c'    <- cNameL c
372         ; cxt'  <- returnL []
373         ; args' <- mapM cvt_id_arg varstrtys
374         ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
375
376 cvtConstr (InfixC st1 c st2)
377   = do  { c' <- cNameL c
378         ; cxt' <- returnL []
379         ; st1' <- cvt_arg st1
380         ; st2' <- cvt_arg st2
381         ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
382
383 cvtConstr (ForallC tvs ctxt con)
384   = do  { tvs'  <- cvtTvs tvs
385         ; L loc ctxt' <- cvtContext ctxt
386         ; L _ con' <- cvtConstr con
387         ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con'))
388                          , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
389
390 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
391 cvt_arg (NotStrict, ty) = cvtType ty
392 cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang Nothing     True) ty' }
393 cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' }
394
395 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
396 cvt_id_arg (i, str, ty)
397   = do  { i' <- vNameL i
398         ; ty' <- cvt_arg (str,ty)
399         ; return (ConDeclField { cd_fld_name = i', cd_fld_type =  ty', cd_fld_doc = Nothing}) }
400
401 cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
402 cvtDerivs [] = return Nothing
403 cvtDerivs cs = do { cs' <- mapM cvt_one cs
404                   ; return (Just cs') }
405         where
406           cvt_one c = do { c' <- tconName c
407                          ; returnL $ HsTyVar c' }
408
409 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
410 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
411
412 noExistentials :: [LHsTyVarBndr RdrName]
413 noExistentials = []
414
415 ------------------------------------------
416 --      Foreign declarations
417 ------------------------------------------
418
419 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
420 cvtForD (ImportF callconv safety from nm ty)
421   | Just impspec <- parseCImport (cvt_conv callconv) safety'
422                                  (mkFastString (TH.nameBase nm)) from
423   = do { nm' <- vNameL nm
424        ; ty' <- cvtType ty
425        ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
426        }
427   | otherwise
428   = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
429   where
430     safety' = case safety of
431                      Unsafe     -> PlayRisky
432                      Safe       -> PlaySafe
433                      Interruptible -> PlayInterruptible
434
435 cvtForD (ExportF callconv as nm ty)
436   = do  { nm' <- vNameL nm
437         ; ty' <- cvtType ty
438         ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
439         ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
440
441 cvt_conv :: TH.Callconv -> CCallConv
442 cvt_conv TH.CCall   = CCallConv
443 cvt_conv TH.StdCall = StdCallConv
444
445 ------------------------------------------
446 --              Pragmas
447 ------------------------------------------
448
449 cvtPragmaD :: Pragma -> CvtM (LHsDecl RdrName)
450 cvtPragmaD (InlineP nm inline rm phases)
451   = do { nm' <- vNameL nm
452        ; let dflt = dfltActivation inline
453        ; let ip   = InlinePragma { inl_inline = cvtInline inline
454                                  , inl_rule   = cvtRuleMatch rm
455                                  , inl_act    = cvtPhases phases dflt
456                                  , inl_sat    = Nothing }
457        ; returnL $ Hs.SigD $ InlineSig nm' ip }
458
459 cvtPragmaD (SpecialiseP nm ty inline phases)
460   = do { nm' <- vNameL nm
461        ; ty' <- cvtType ty
462        ; let (inline', dflt) = case inline of
463                Just inline1 -> (cvtInline inline1, dfltActivation inline1)
464                Nothing      -> (EmptyInlineSpec,   AlwaysActive)
465        ; let ip = InlinePragma { inl_inline = inline'
466                                , inl_rule   = Hs.FunLike
467                                , inl_act    = cvtPhases phases dflt
468                                , inl_sat    = Nothing }
469        ; returnL $ Hs.SigD $ SpecSig nm' ty' ip }
470
471 cvtPragmaD (SpecialiseInstP ty)
472   = do { ty' <- cvtType ty
473        ; returnL $ Hs.SigD $ SpecInstSig ty' }
474
475 cvtPragmaD (RuleP nm bndrs lhs rhs phases)
476   = do { let nm' = mkFastString nm
477        ; let act = cvtPhases phases AlwaysActive
478        ; bndrs' <- mapM cvtRuleBndr bndrs
479        ; lhs'   <- cvtl lhs
480        ; rhs'   <- cvtl rhs
481        ; returnL $ Hs.RuleD $ HsRule nm' act bndrs'
482                                      lhs' placeHolderNames
483                                      rhs' placeHolderNames
484        }
485
486 cvtPragmaD (AnnP target exp)
487   = do { exp' <- cvtl exp
488        ; target' <- case target of
489          ModuleAnnotation  -> return ModuleAnnProvenance
490          TypeAnnotation n  -> do
491            n' <- tconName n
492            return (TypeAnnProvenance  n')
493          ValueAnnotation n -> do
494            n' <- if isVarName n then vName n else cName n
495            return (ValueAnnProvenance n')
496        ; returnL $ Hs.AnnD $ HsAnnotation target' exp'
497        }
498
499 dfltActivation :: TH.Inline -> Activation
500 dfltActivation TH.NoInline = NeverActive
501 dfltActivation _           = AlwaysActive
502
503 cvtInline :: TH.Inline -> Hs.InlineSpec
504 cvtInline TH.NoInline  = Hs.NoInline
505 cvtInline TH.Inline    = Hs.Inline
506 cvtInline TH.Inlinable = Hs.Inlinable
507
508 cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
509 cvtRuleMatch TH.ConLike = Hs.ConLike
510 cvtRuleMatch TH.FunLike = Hs.FunLike
511
512 cvtPhases :: TH.Phases -> Activation -> Activation
513 cvtPhases AllPhases       dflt = dflt
514 cvtPhases (FromPhase i)   _    = ActiveAfter i
515 cvtPhases (BeforePhase i) _    = ActiveBefore i
516
517 cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.RuleBndr RdrName)
518 cvtRuleBndr (RuleVar n)
519   = do { n' <- vNameL n
520        ; return $ Hs.RuleBndr n' }
521 cvtRuleBndr (TypedRuleVar n ty)
522   = do { n'  <- vNameL n
523        ; ty' <- cvtType ty
524        ; return $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
525
526 ---------------------------------------------------
527 --              Declarations
528 ---------------------------------------------------
529
530 cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
531 cvtLocalDecs doc ds
532   | null ds
533   = return EmptyLocalBinds
534   | otherwise
535   = do { ds' <- mapM cvtDec ds
536        ; let (binds, prob_sigs) = partitionWith is_bind ds'
537        ; let (sigs, bads) = partitionWith is_sig prob_sigs
538        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
539        ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
540
541 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
542 cvtClause (Clause ps body wheres)
543   = do  { ps' <- cvtPats ps
544         ; g'  <- cvtGuard body
545         ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
546         ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
547
548
549 -------------------------------------------------------------------
550 --              Expressions
551 -------------------------------------------------------------------
552
553 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
554 cvtl e = wrapL (cvt e)
555   where
556     cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
557     cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
558     cvt (LitE l)
559       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
560       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
561
562     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
563     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
564                             ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
565     cvt (LamCaseE ms)  = do { ms' <- mapM cvtMatch ms
566                             ; return $ HsLamCase placeHolderType
567                                                  (mkMatchGroup FromSource ms')
568                             }
569     cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
570                                  -- Note [Dropping constructors]
571                                  -- Singleton tuples treated like nothing (just parens)
572     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
573     cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
574     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
575                             ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
576     cvt (MultiIfE alts)
577       | null alts      = failWith (ptext (sLit "Multi-way if-expression with no alternatives"))
578       | otherwise      = do { alts' <- mapM cvtpair alts
579                             ; return $ HsMultiIf placeHolderType alts' }
580     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
581                             ; e' <- cvtl e; return $ HsLet ds' e' }
582     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
583                             ; return $ HsCase e' (mkMatchGroup FromSource ms') }
584     cvt (DoE ss)       = cvtHsDo DoExpr ss
585     cvt (CompE ss)     = cvtHsDo ListComp ss
586     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
587     cvt (ListE xs)
588       | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
589              -- Note [Converting strings]
590       | otherwise                    = do { xs' <- mapM cvtl xs; return $ ExplicitList void Nothing xs' }
591
592     -- Infix expressions
593     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
594                                           ; wrapParL HsPar $
595                                             OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
596                                             -- Parenthesise both arguments and result,
597                                             -- to ensure this operator application does
598                                             -- does not get re-associated
599                             -- See Note [Operator association]
600     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
601                                           ; wrapParL HsPar $ SectionR s' y' }
602                                             -- See Note [Sections in HsSyn] in HsExpr
603     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
604                                           ; wrapParL HsPar $ SectionL x' s' }
605
606     cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
607                                        -- Can I indicate this is an infix thing?
608                                        -- Note [Dropping constructors]
609
610     cvt (UInfixE x s y)  = do { x' <- cvtl x
611                               ; let x'' = case x' of
612                                             L _ (OpApp {}) -> x'
613                                             _ -> mkLHsPar x'
614                               ; cvtOpApp x'' s y } --  Note [Converting UInfix]
615
616     cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar e' }
617     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
618                               ; return $ ExprWithTySig e' t' }
619     cvt (RecConE c flds) = do { c' <- cNameL c
620                               ; flds' <- mapM cvtFld flds
621                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
622     cvt (RecUpdE e flds) = do { e' <- cvtl e
623                               ; flds' <- mapM cvtFld flds
624                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
625
626 {- Note [Dropping constructors]
627 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
628 When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
629 we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
630 could meet @UInfix@ constructors containing the @TupE [e]@. For example:
631
632   UInfixE x * (TupE [UInfixE y + z])
633
634 If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
635 and the above expression would be reassociated to
636
637   OpApp (OpApp x * y) + z
638
639 which we don't want.
640 -}
641
642 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
643 cvtFld (v,e)
644   = do  { v' <- vNameL v; e' <- cvtl e
645         ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
646
647 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
648 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
649 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
650 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
651 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
652
653 {- Note [Operator assocation]
654 We must be quite careful about adding parens:
655   * Infix (UInfix ...) op arg      Needs parens round the first arg
656   * Infix (Infix ...) op arg       Needs parens round the first arg
657   * UInfix (UInfix ...) op arg     No parens for first arg
658   * UInfix (Infix ...) op arg      Needs parens round first arg
659
660
661 Note [Converting UInfix]
662 ~~~~~~~~~~~~~~~~~~~~~~~~
663 When converting @UInfixE@ and @UInfixP@ values, we want to readjust
664 the trees to reflect the fixities of the underlying operators:
665
666   UInfixE x * (UInfixE y + z) ---> (x * y) + z
667
668 This is done by the renamer (see @mkOppAppRn@ and @mkConOppPatRn@ in
669 RnTypes), which expects that the input will be completely left-biased.
670 So we left-bias the trees  of @UInfixP@ and @UInfixE@ that we come across.
671
672 Sample input:
673
674   UInfixE
675    (UInfixE x op1 y)
676    op2
677    (UInfixE z op3 w)
678
679 Sample output:
680
681   OpApp
682     (OpApp
683       (OpApp x op1 y)
684       op2
685       z)
686     op3
687     w
688
689 The functions @cvtOpApp@ and @cvtOpAppP@ are responsible for this
690 left-biasing.
691 -}
692
693 {- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
694 The produced tree of infix expressions will be left-biased, provided @x@ is.
695
696 We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
697 is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
698 this holds for both branches (of @cvtOpApp@), provided we assume it holds for
699 the recursive calls to @cvtOpApp@.
700
701 When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
702 since we have already run @cvtl@ on it.
703 -}
704 cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName)
705 cvtOpApp x op1 (UInfixE y op2 z)
706   = do { l <- wrapL $ cvtOpApp x op1 y
707        ; cvtOpApp l op2 z }
708 cvtOpApp x op y
709   = do { op' <- cvtl op
710        ; y' <- cvtl y
711        ; return (OpApp x op' undefined y') }
712
713 -------------------------------------
714 --      Do notation and statements
715 -------------------------------------
716
717 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
718 cvtHsDo do_or_lc stmts
719   | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
720   | otherwise
721   = do  { stmts' <- cvtStmts stmts
722         ; let Just (stmts'', last') = snocView stmts'
723
724         ; last'' <- case last' of
725                     L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
726                     _ -> failWith (bad_last last')
727
728         ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
729   where
730     bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
731                          , nest 2 $ Outputable.ppr stmt
732                          , ptext (sLit "(It should be an expression.)") ]
733
734 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)]
735 cvtStmts = mapM cvtStmt
736
737 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName))
738 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
739 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
740 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
741                             ; returnL $ LetStmt ds' }
742 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr }
743                        where
744                          cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
745
746 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
747 cvtMatch (TH.Match p body decs)
748   = do  { p' <- cvtPat p
749         ; g' <- cvtGuard body
750         ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
751         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
752
753 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
754 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
755 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
756
757 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName))
758 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
759                               ; g' <- returnL $ mkBodyStmt ge'
760                               ; returnL $ GRHS [g'] rhs' }
761 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
762                               ; returnL $ GRHS gs' rhs' }
763
764 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
765 cvtOverLit (IntegerL i)
766   = do { force i; return $ mkHsIntegral i placeHolderType}
767 cvtOverLit (RationalL r)
768   = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
769 cvtOverLit (StringL s)
770   = do { let { s' = mkFastString s }
771        ; force s'
772        ; return $ mkHsIsString s' placeHolderType
773        }
774 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
775 -- An Integer is like an (overloaded) '3' in a Haskell source program
776 -- Similarly 3.5 for fractionals
777
778 {- Note [Converting strings]
779 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
780 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
781 a string literal for "xy".  Of course, we might hope to get
782 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
783 if it isn't a literal string
784 -}
785
786 allCharLs :: [TH.Exp] -> Maybe String
787 -- Note [Converting strings]
788 -- NB: only fire up this setup for a non-empty list, else
789 --     there's a danger of returning "" for [] :: [Int]!
790 allCharLs xs
791   = case xs of
792       LitE (CharL c) : ys -> go [c] ys
793       _                   -> Nothing
794   where
795     go cs []                    = Just (reverse cs)
796     go cs (LitE (CharL c) : ys) = go (c:cs) ys
797     go _  _                     = Nothing
798
799 cvtLit :: Lit -> CvtM HsLit
800 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
801 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
802 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
803 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
804 cvtLit (CharL c)       = do { force c; return $ HsChar c }
805 cvtLit (StringL s)     = do { let { s' = mkFastString s }
806                             ; force s'
807                             ; return $ HsString s' }
808 cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
809                             ; force s'
810                             ; return $ HsStringPrim s' }
811 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
812         -- cvtLit should not be called on IntegerL, RationalL
813         -- That precondition is established right here in
814         -- Convert.lhs, hence panic
815
816 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
817 cvtPats pats = mapM cvtPat pats
818
819 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
820 cvtPat pat = wrapL (cvtp pat)
821
822 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
823 cvtp (TH.LitP l)
824   | overloadedLit l    = do { l' <- cvtOverLit l
825                             ; return (mkNPat l' Nothing) }
826                                   -- Not right for negative patterns;
827                                   -- need to think about that!
828   | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat l' }
829 cvtp (TH.VarP s)       = do { s' <- vName s; return $ Hs.VarPat s' }
830 cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
831 cvtp (TupP ps)         = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
832 cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void }
833 cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps
834                             ; return $ ConPatIn s' (PrefixCon ps') }
835 cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
836                             ; wrapParL ParPat $
837                               ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
838                             -- See Note [Operator association]
839 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
840 cvtp (ParensP p)       = do { p' <- cvtPat p; return $ ParPat p' }
841 cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat p' }
842 cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat p' }
843 cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
844 cvtp TH.WildP          = return $ WildPat void
845 cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
846                             ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
847 cvtp (ListP ps)        = do { ps' <- cvtPats ps; return $ ListPat ps' void Nothing }
848 cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
849                             ; return $ SigPatIn p' (mkHsWithBndrs t') }
850 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
851
852 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
853 cvtPatFld (s,p)
854   = do  { s' <- vNameL s; p' <- cvtPat p
855         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
856
857 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
858 The produced tree of infix patterns will be left-biased, provided @x@ is.
859
860 See the @cvtOpApp@ documentation for how this function works.
861 -}
862 cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName)
863 cvtOpAppP x op1 (UInfixP y op2 z)
864   = do { l <- wrapL $ cvtOpAppP x op1 y
865        ; cvtOpAppP l op2 z }
866 cvtOpAppP x op y
867   = do { op' <- cNameL op
868        ; y' <- cvtPat y
869        ; return (ConPatIn op' (InfixCon x y')) }
870
871 -----------------------------------------------------------
872 --      Types and type variables
873
874 cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName)
875 cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
876
877 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
878 cvt_tv (TH.PlainTV nm)
879   = do { nm' <- tName nm
880        ; returnL $ UserTyVar nm' }
881 cvt_tv (TH.KindedTV nm ki)
882   = do { nm' <- tName nm
883        ; ki' <- cvtKind ki
884        ; returnL $ KindedTyVar nm' ki' }
885
886 cvtRole :: TH.Role -> Maybe Coercion.Role
887 cvtRole TH.NominalR          = Just Coercion.Nominal
888 cvtRole TH.RepresentationalR = Just Coercion.Representational
889 cvtRole TH.PhantomR          = Just Coercion.Phantom
890 cvtRole TH.InferR            = Nothing
891
892 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
893 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
894
895 cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
896 cvtPred = cvtType
897
898 cvtType :: TH.Type -> CvtM (LHsType RdrName)
899 cvtType = cvtTypeKind "type"
900
901 cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName)
902 cvtTypeKind ty_str ty
903   = do { (head_ty, tys') <- split_ty_app ty
904        ; case head_ty of
905            TupleT n
906              | length tys' == n         -- Saturated
907              -> if n==1 then return (head tys') -- Singleton tuples treated
908                                                 -- like nothing (ie just parens)
909                         else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
910              | n == 1
911              -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
912              | otherwise
913              -> mk_apps (HsTyVar (getRdrName (tupleTyCon BoxedTuple n))) tys'
914            UnboxedTupleT n
915              | length tys' == n         -- Saturated
916              -> if n==1 then return (head tys') -- Singleton tuples treated
917                                                 -- like nothing (ie just parens)
918                         else returnL (HsTupleTy HsUnboxedTuple tys')
919              | otherwise
920              -> mk_apps (HsTyVar (getRdrName (tupleTyCon UnboxedTuple n))) tys'
921            ArrowT
922              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
923              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
924            ListT
925              | [x']    <- tys' -> returnL (HsListTy x')
926              | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
927            VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
928            ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
929
930            ForallT tvs cxt ty
931              | null tys'
932              -> do { tvs' <- cvtTvs tvs
933                    ; cxt' <- cvtContext cxt
934                    ; ty'  <- cvtType ty
935                    ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty'
936                    }
937
938            SigT ty ki
939              -> do { ty' <- cvtType ty
940                    ; ki' <- cvtKind ki
941                    ; mk_apps (HsKindSig ty' ki') tys'
942                    }
943
944            LitT lit
945              -> returnL (HsTyLit (cvtTyLit lit))
946
947            PromotedT nm -> do { nm' <- cName nm; mk_apps (HsTyVar nm') tys' }
948                  -- Promoted data constructor; hence cName
949
950            PromotedTupleT n
951              | n == 1
952              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
953              | m == n   -- Saturated
954              -> do  { let kis = replicate m placeHolderKind
955                     ; returnL (HsExplicitTupleTy kis tys')
956                     }
957              where
958                m = length tys'
959
960            PromotedNilT
961              -> returnL (HsExplicitListTy placeHolderKind [])
962
963            PromotedConsT  -- See Note [Representing concrete syntax in types]
964                           -- in Language.Haskell.TH.Syntax
965              | [ty1, L _ (HsExplicitListTy _ tys2)] <- tys'
966              -> returnL (HsExplicitListTy placeHolderKind (ty1:tys2))
967              | otherwise
968              -> mk_apps (HsTyVar (getRdrName consDataCon)) tys'
969
970            StarT
971              -> returnL (HsTyVar (getRdrName liftedTypeKindTyCon))
972
973            ConstraintT
974              -> returnL (HsTyVar (getRdrName constraintKindTyCon))
975
976            EqualityT
977              | [x',y'] <- tys' -> returnL (HsEqTy x' y')
978              | otherwise       -> mk_apps (HsTyVar (getRdrName eqPrimTyCon)) tys'
979
980            _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
981     }
982
983 mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
984 mk_apps head_ty []       = returnL head_ty
985 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
986                               ; mk_apps (HsAppTy head_ty' ty) tys }
987
988 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
989 split_ty_app ty = go ty []
990   where
991     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
992     go f as           = return (f,as)
993
994 cvtTyLit :: TH.TyLit -> HsTyLit
995 cvtTyLit (NumTyLit i) = HsNumTy i
996 cvtTyLit (StrTyLit s) = HsStrTy (fsLit s)
997
998 cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
999 cvtKind = cvtTypeKind "kind"
1000
1001 cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
1002 cvtMaybeKind Nothing = return Nothing
1003 cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
1004                             ; return (Just ki') }
1005
1006 -----------------------------------------------------------
1007 cvtFixity :: TH.Fixity -> Hs.Fixity
1008 cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir)
1009    where
1010      cvt_dir TH.InfixL = Hs.InfixL
1011      cvt_dir TH.InfixR = Hs.InfixR
1012      cvt_dir TH.InfixN = Hs.InfixN
1013
1014 -----------------------------------------------------------
1015
1016
1017 -----------------------------------------------------------
1018 -- some useful things
1019
1020 overloadedLit :: Lit -> Bool
1021 -- True for literals that Haskell treats as overloaded
1022 overloadedLit (IntegerL  _) = True
1023 overloadedLit (RationalL _) = True
1024 overloadedLit _             = False
1025
1026 void :: Type.Type
1027 void = placeHolderType
1028
1029 cvtFractionalLit :: Rational -> FractionalLit
1030 cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
1031
1032 --------------------------------------------------------------------
1033 --      Turning Name back into RdrName
1034 --------------------------------------------------------------------
1035
1036 -- variable names
1037 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
1038 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
1039
1040 vNameL n = wrapL (vName n)
1041 vName n = cvtName OccName.varName n
1042
1043 -- Constructor function names; this is Haskell source, hence srcDataName
1044 cNameL n = wrapL (cName n)
1045 cName n = cvtName OccName.dataName n
1046
1047 -- Type variable names
1048 tName n = cvtName OccName.tvName n
1049
1050 -- Type Constructor names
1051 tconNameL n = wrapL (tconName n)
1052 tconName n = cvtName OccName.tcClsName n
1053
1054 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
1055 cvtName ctxt_ns (TH.Name occ flavour)
1056   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
1057   | otherwise
1058   = do { loc <- getL
1059        ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
1060        ; force rdr_name
1061        ; return rdr_name }
1062   where
1063     occ_str = TH.occString occ
1064
1065 okOcc :: OccName.NameSpace -> String -> Bool
1066 okOcc _  []      = False
1067 okOcc ns str@(c:_)
1068   | OccName.isVarNameSpace ns     = startsVarId c || startsVarSym c
1069   | OccName.isDataConNameSpace ns = startsConId c || startsConSym c || str == "[]"
1070   | otherwise                     = startsConId c || startsConSym c ||
1071                                     startsVarSym c || str == "[]" || str == "->"
1072                                      -- allow type operators like "+"
1073
1074 -- Determine the name space of a name in a type
1075 --
1076 isVarName :: TH.Name -> Bool
1077 isVarName (TH.Name occ _)
1078   = case TH.occString occ of
1079       ""    -> False
1080       (c:_) -> startsVarId c || startsVarSym c
1081
1082 badOcc :: OccName.NameSpace -> String -> SDoc
1083 badOcc ctxt_ns occ
1084   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
1085         <+> ptext (sLit "name:") <+> quotes (text occ)
1086
1087 thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
1088 -- This turns a TH Name into a RdrName; used for both binders and occurrences
1089 -- See Note [Binders in Template Haskell]
1090 -- The passed-in name space tells what the context is expecting;
1091 --      use it unless the TH name knows what name-space it comes
1092 --      from, in which case use the latter
1093 --
1094 -- We pass in a SrcSpan (gotten from the monad) because this function
1095 -- is used for *binders* and if we make an Exact Name we want it
1096 -- to have a binding site inside it.  (cf Trac #5434)
1097 --
1098 -- ToDo: we may generate silly RdrNames, by passing a name space
1099 --       that doesn't match the string, like VarName ":+",
1100 --       which will give confusing error messages later
1101 --
1102 -- The strict applications ensure that any buried exceptions get forced
1103 thRdrName loc ctxt_ns th_occ th_name
1104   = case th_name of
1105      TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
1106      TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ
1107      TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
1108      TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
1109      TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
1110               | otherwise                           -> mkRdrUnqual $! occ
1111               -- We check for built-in syntax here, because the TH
1112               -- user might have written a (NameS "(,,)"), for example
1113   where
1114     occ :: OccName.OccName
1115     occ = mk_occ ctxt_ns th_occ
1116
1117 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
1118 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
1119
1120 thRdrNameGuesses :: TH.Name -> [RdrName]
1121 thRdrNameGuesses (TH.Name occ flavour)
1122   -- This special case for NameG ensures that we don't generate duplicates in the output list
1123   | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
1124   | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour
1125                                         | gns <- guessed_nss]
1126   where
1127     -- guessed_ns are the name spaces guessed from looking at the TH name
1128     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
1129                 | otherwise                       = [OccName.varName, OccName.tvName]
1130     occ_str = TH.occString occ
1131
1132 -- The packing and unpacking is rather turgid :-(
1133 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
1134 mk_occ ns occ = OccName.mkOccName ns occ
1135
1136 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
1137 mk_ghc_ns TH.DataName  = OccName.dataName
1138 mk_ghc_ns TH.TcClsName = OccName.tcClsName
1139 mk_ghc_ns TH.VarName   = OccName.varName
1140
1141 mk_mod :: TH.ModName -> ModuleName
1142 mk_mod mod = mkModuleName (TH.modString mod)
1143
1144 mk_pkg :: TH.PkgName -> PackageId
1145 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
1146
1147 mk_uniq :: Int# -> Unique
1148 mk_uniq u = mkUniqueGrimily (I# u)
1149 \end{code}
1150
1151 Note [Binders in Template Haskell]
1152 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1153 Consider this TH term construction:
1154   do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name
1155      ; x2 <- TH.newName "x"   -- Builds a NameU
1156      ; x3 <- TH.newName "x"
1157
1158      ; let x = mkName "x"     -- mkName :: String -> TH.Name
1159                               -- Builds a NameL
1160
1161      ; return (LamE (..pattern [x1,x2]..) $
1162                LamE (VarPat x3) $
1163                ..tuple (x1,x2,x3,x)) }
1164
1165 It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)
1166
1167 a) We don't want to complain about "x" being bound twice in
1168    the pattern [x1,x2]
1169 b) We don't want x3 to shadow the x1,x2
1170 c) We *do* want 'x' (dynamically bound with mkName) to bind
1171    to the innermost binding of "x", namely x3.
1172 d) When pretty printing, we want to print a unique with x1,x2
1173    etc, else they'll all print as "x" which isn't very helpful
1174
1175 When we convert all this to HsSyn, the TH.Names are converted with
1176 thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.
1177 Achieving (a) is a bit awkward, because
1178    - We must check for duplicate and shadowed names on Names,
1179      not RdrNames, *after* renaming.
1180      See Note [Collect binders only after renaming] in HsUtils
1181
1182    - But to achieve (a) we must distinguish between the Exact
1183      RdrNames arising from TH and the Unqual RdrNames that would
1184      come from a user writing \[x,x] -> blah
1185
1186 So in Convert.thRdrName we translate
1187    TH Name                          RdrName
1188    --------------------------------------------------------
1189    NameU (arising from newName) --> Exact (Name{ System })
1190    NameS (arising from mkName)  --> Unqual
1191
1192 Notice that the NameUs generate *System* Names.  Then, when
1193 figuring out shadowing and duplicates, we can filter out
1194 System Names.
1195
1196 This use of System Names fits with other uses of System Names, eg for
1197 temporary variables "a". Since there are lots of things called "a" we
1198 usually want to print the name with the unique, and that is indeed
1199 the way System Names are printed.
1200
1201 There's a small complication of course; see Note [Looking up Exact
1202 RdrNames] in RnEnv.