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