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