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