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