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