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