Merge branch 'master' of http://darcs.haskell.org/ghc
[ghc.git] / compiler / hsSyn / Convert.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 This module converts Template Haskell syntax into HsSyn
7
8 \begin{code}
9 {-# 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 | inline    = Inline
437              | otherwise = NoInline
438              -- Currently we have no way to say Inlinable
439
440     cvtActivation Nothing | inline      = AlwaysActive
441                           | otherwise   = NeverActive
442     cvtActivation (Just (False, phase)) = ActiveBefore phase
443     cvtActivation (Just (True , phase)) = ActiveAfter  phase
444
445 ---------------------------------------------------
446 --              Declarations
447 ---------------------------------------------------
448
449 cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
450 cvtLocalDecs doc ds 
451   | null ds
452   = return EmptyLocalBinds
453   | otherwise
454   = do { ds' <- mapM cvtDec ds
455        ; let (binds, prob_sigs) = partitionWith is_bind ds'
456        ; let (sigs, bads) = partitionWith is_sig prob_sigs
457        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
458        ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
459
460 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
461 cvtClause (Clause ps body wheres)
462   = do  { ps' <- cvtPats ps
463         ; g'  <- cvtGuard body
464         ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
465         ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
466
467
468 -------------------------------------------------------------------
469 --              Expressions
470 -------------------------------------------------------------------
471
472 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
473 cvtl e = wrapL (cvt e)
474   where
475     cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
476     cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
477     cvt (LitE l) 
478       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
479       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
480
481     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
482     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e 
483                             ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
484     cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
485                                  -- Note [Dropping constructors]
486                                  -- Singleton tuples treated like nothing (just parens)
487     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
488     cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
489     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
490                             ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
491     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
492                             ; e' <- cvtl e; return $ HsLet ds' e' }
493     cvt (CaseE e ms)   
494        | null ms       = failWith (ptext (sLit "Case expression with no alternatives"))
495        | otherwise     = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
496                             ; return $ HsCase e' (mkMatchGroup ms') }
497     cvt (DoE ss)       = cvtHsDo DoExpr ss
498     cvt (CompE ss)     = cvtHsDo ListComp ss
499     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
500     cvt (ListE xs)     
501       | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
502              -- Note [Converting strings]
503       | otherwise                    = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
504
505     -- Infix expressions
506     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
507                                           ; wrapParL HsPar $ 
508                                             OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
509                                             -- Parenthesise both arguments and result, 
510                                             -- to ensure this operator application does
511                                             -- does not get re-associated
512                             -- See Note [Operator association]
513     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
514                                           ; wrapParL HsPar $ SectionR s' y' }
515                                             -- See Note [Sections in HsSyn] in HsExpr
516     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
517                                           ; wrapParL HsPar $ SectionL x' s' }
518
519     cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
520                                        -- Can I indicate this is an infix thing?
521                                        -- Note [Dropping constructors]
522
523     cvt (UInfixE x s y)  = do { x' <- cvtl x
524                               ; let x'' = case x' of 
525                                             L _ (OpApp {}) -> x'
526                                             _ -> mkLHsPar x'
527                               ; cvtOpApp x'' s y } --  Note [Converting UInfix]
528
529     cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar e' }
530     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
531                               ; return $ ExprWithTySig e' t' }
532     cvt (RecConE c flds) = do { c' <- cNameL c
533                               ; flds' <- mapM cvtFld flds
534                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
535     cvt (RecUpdE e flds) = do { e' <- cvtl e
536                               ; flds' <- mapM cvtFld flds
537                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
538
539 {- Note [Dropping constructors]
540 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
541 When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
542 we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
543 could meet @UInfix@ constructors containing the @TupE [e]@. For example:
544
545   UInfixE x * (TupE [UInfixE y + z])
546
547 If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
548 and the above expression would be reassociated to
549
550   OpApp (OpApp x * y) + z
551
552 which we don't want.
553 -}
554
555 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
556 cvtFld (v,e) 
557   = do  { v' <- vNameL v; e' <- cvtl e
558         ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
559
560 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
561 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
562 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
563 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
564 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
565
566 {- Note [Operator assocation]
567 We must be quite careful about adding parens:
568   * Infix (UInfix ...) op arg      Needs parens round the first arg
569   * Infix (Infix ...) op arg       Needs parens round the first arg
570   * UInfix (UInfix ...) op arg     No parens for first arg
571   * UInfix (Infix ...) op arg      Needs parens round first arg
572
573
574 Note [Converting UInfix]
575 ~~~~~~~~~~~~~~~~~~~~~~~~
576 When converting @UInfixE@ and @UInfixP@ values, we want to readjust
577 the trees to reflect the fixities of the underlying operators:
578
579   UInfixE x * (UInfixE y + z) ---> (x * y) + z
580
581 This is done by the renamer (see @mkOppAppRn@ and @mkConOppPatRn@ in
582 RnTypes), which expects that the input will be completely left-biased.
583 So we left-bias the trees  of @UInfixP@ and @UInfixE@ that we come across.
584
585 Sample input:
586
587   UInfixE
588    (UInfixE x op1 y)
589    op2
590    (UInfixE z op3 w)
591
592 Sample output:
593
594   OpApp
595     (OpApp
596       (OpApp x op1 y)
597       op2
598       z)
599     op3
600     w
601
602 The functions @cvtOpApp@ and @cvtOpAppP@ are responsible for this
603 left-biasing.
604 -}
605
606 {- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
607 The produced tree of infix expressions will be left-biased, provided @x@ is.
608
609 We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
610 is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
611 this holds for both branches (of @cvtOpApp@), provided we assume it holds for
612 the recursive calls to @cvtOpApp@.
613
614 When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
615 since we have already run @cvtl@ on it.
616 -}
617 cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName)
618 cvtOpApp x op1 (UInfixE y op2 z)
619   = do { l <- wrapL $ cvtOpApp x op1 y
620        ; cvtOpApp l op2 z }
621 cvtOpApp x op y
622   = do { op' <- cvtl op
623        ; y' <- cvtl y
624        ; return (OpApp x op' undefined y') }
625
626 -------------------------------------
627 --      Do notation and statements
628 -------------------------------------
629
630 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
631 cvtHsDo do_or_lc stmts
632   | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
633   | otherwise
634   = do  { stmts' <- cvtStmts stmts
635         ; let Just (stmts'', last') = snocView stmts'
636         
637         ; last'' <- case last' of
638                       L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body))
639                       _ -> failWith (bad_last last')
640
641         ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
642   where
643     bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
644                          , nest 2 $ Outputable.ppr stmt
645                          , ptext (sLit "(It should be an expression.)") ]
646                 
647 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
648 cvtStmts = mapM cvtStmt 
649
650 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
651 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
652 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
653 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
654                             ; returnL $ LetStmt ds' }
655 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr }
656                        where
657                          cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
658
659 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
660 cvtMatch (TH.Match p body decs)
661   = do  { p' <- cvtPat p
662         ; g' <- cvtGuard body
663         ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
664         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
665
666 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
667 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
668 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
669
670 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
671 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
672                               ; g' <- returnL $ mkExprStmt ge'
673                               ; returnL $ GRHS [g'] rhs' }
674 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
675                               ; returnL $ GRHS gs' rhs' }
676
677 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
678 cvtOverLit (IntegerL i)  
679   = do { force i; return $ mkHsIntegral i placeHolderType}
680 cvtOverLit (RationalL r) 
681   = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
682 cvtOverLit (StringL s)   
683   = do { let { s' = mkFastString s }
684        ; force s'
685        ; return $ mkHsIsString s' placeHolderType 
686        }
687 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
688 -- An Integer is like an (overloaded) '3' in a Haskell source program
689 -- Similarly 3.5 for fractionals
690
691 {- Note [Converting strings] 
692 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
693 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
694 a string literal for "xy".  Of course, we might hope to get 
695 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
696 if it isn't a literal string
697 -}
698
699 allCharLs :: [TH.Exp] -> Maybe String
700 -- Note [Converting strings]
701 -- NB: only fire up this setup for a non-empty list, else
702 --     there's a danger of returning "" for [] :: [Int]!
703 allCharLs xs
704   = case xs of 
705       LitE (CharL c) : ys -> go [c] ys
706       _                   -> Nothing
707   where
708     go cs []                    = Just (reverse cs)
709     go cs (LitE (CharL c) : ys) = go (c:cs) ys
710     go _  _                     = Nothing
711
712 cvtLit :: Lit -> CvtM HsLit
713 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
714 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
715 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
716 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
717 cvtLit (CharL c)       = do { force c; return $ HsChar c }
718 cvtLit (StringL s)     = do { let { s' = mkFastString s }
719                             ; force s'      
720                             ; return $ HsString s' }
721 cvtLit (StringPrimL s) = do { let { s' = mkFastString s }
722                             ; force s'           
723                             ; return $ HsStringPrim s' }
724 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
725         -- cvtLit should not be called on IntegerL, RationalL
726         -- That precondition is established right here in
727         -- Convert.lhs, hence panic
728
729 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
730 cvtPats pats = mapM cvtPat pats
731
732 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
733 cvtPat pat = wrapL (cvtp pat)
734
735 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
736 cvtp (TH.LitP l)
737   | overloadedLit l    = do { l' <- cvtOverLit l
738                             ; return (mkNPat l' Nothing) }
739                                   -- Not right for negative patterns; 
740                                   -- need to think about that!
741   | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat l' }
742 cvtp (TH.VarP s)       = do { s' <- vName s; return $ Hs.VarPat s' }
743 cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
744 cvtp (TupP ps)         = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
745 cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void }
746 cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps
747                             ; return $ ConPatIn s' (PrefixCon ps') }
748 cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
749                             ; wrapParL ParPat $ 
750                               ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
751                             -- See Note [Operator association]
752 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
753 cvtp (ParensP p)       = do { p' <- cvtPat p; return $ ParPat p' }
754 cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat p' }
755 cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat p' }
756 cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
757 cvtp TH.WildP          = return $ WildPat void
758 cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
759                             ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
760 cvtp (ListP ps)        = do { ps' <- cvtPats ps; return $ ListPat ps' void }
761 cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
762                             ; return $ SigPatIn p' (mkHsWithBndrs t') }
763 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
764
765 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
766 cvtPatFld (s,p)
767   = do  { s' <- vNameL s; p' <- cvtPat p
768         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
769
770 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
771 The produced tree of infix patterns will be left-biased, provided @x@ is.
772
773 See the @cvtOpApp@ documentation for how this function works.
774 -}
775 cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName)
776 cvtOpAppP x op1 (UInfixP y op2 z)
777   = do { l <- wrapL $ cvtOpAppP x op1 y
778        ; cvtOpAppP l op2 z }
779 cvtOpAppP x op y
780   = do { op' <- cNameL op
781        ; y' <- cvtPat y
782        ; return (ConPatIn op' (InfixCon x y')) }
783
784 -----------------------------------------------------------
785 --      Types and type variables
786
787 cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName)
788 cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
789
790 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
791 cvt_tv (TH.PlainTV nm) 
792   = do { nm' <- tName nm
793        ; returnL $ UserTyVar nm' }
794 cvt_tv (TH.KindedTV nm ki) 
795   = do { nm' <- tName nm
796        ; ki' <- cvtKind ki
797        ; returnL $ KindedTyVar nm' ki' }
798
799 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
800 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
801
802 cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
803 cvtPred (TH.ClassP cla tys)
804   = do { cla' <- if isVarName cla then tName cla else tconName cla
805        ; tys' <- mapM cvtType tys
806        ; mk_apps (HsTyVar cla') tys'
807        }
808 cvtPred (TH.EqualP ty1 ty2)
809   = do { ty1' <- cvtType ty1
810        ; ty2' <- cvtType ty2
811        ; returnL $ HsEqTy ty1' ty2'
812        }
813
814 cvtType :: TH.Type -> CvtM (LHsType RdrName)
815 cvtType ty 
816   = do { (head_ty, tys') <- split_ty_app ty
817        ; case head_ty of
818            TupleT n 
819              | length tys' == n         -- Saturated
820              -> if n==1 then return (head tys') -- Singleton tuples treated 
821                                                 -- like nothing (ie just parens)
822                         else returnL (HsTupleTy HsBoxedTuple tys')
823              | n == 1    
824              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
825              | otherwise 
826              -> mk_apps (HsTyVar (getRdrName (tupleTyCon BoxedTuple n))) tys'
827            UnboxedTupleT n
828              | length tys' == n         -- Saturated
829              -> if n==1 then return (head tys') -- Singleton tuples treated
830                                                 -- like nothing (ie just parens)
831                         else returnL (HsTupleTy HsUnboxedTuple tys')
832              | otherwise
833              -> mk_apps (HsTyVar (getRdrName (tupleTyCon UnboxedTuple n))) tys'
834            ArrowT 
835              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
836              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
837            ListT  
838              | [x']    <- tys' -> returnL (HsListTy x')
839              | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
840            VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
841            ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
842
843            ForallT tvs cxt ty 
844              | null tys' 
845              -> do { tvs' <- cvtTvs tvs
846                    ; cxt' <- cvtContext cxt
847                    ; ty'  <- cvtType ty
848                    ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty' 
849                    }
850
851            SigT ty ki
852              -> do { ty' <- cvtType ty
853                    ; ki' <- cvtKind ki
854                    ; mk_apps (HsKindSig ty' ki') tys'
855                    }
856
857            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
858     }
859
860 mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
861 mk_apps head_ty []       = returnL head_ty
862 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
863                               ; mk_apps (HsAppTy head_ty' ty) tys }
864
865 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
866 split_ty_app ty = go ty []
867   where
868     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
869     go f as           = return (f,as)
870
871 cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
872 cvtKind StarK          = returnL (HsTyVar (getRdrName liftedTypeKindTyCon))
873 cvtKind (ArrowK k1 k2) = do
874   k1' <- cvtKind k1
875   k2' <- cvtKind k2
876   returnL (HsFunTy k1' k2')
877
878 cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
879 cvtMaybeKind Nothing = return Nothing
880 cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
881                             ; return (Just ki') }
882
883 -----------------------------------------------------------
884 cvtFixity :: TH.Fixity -> Hs.Fixity
885 cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir)
886    where
887      cvt_dir TH.InfixL = Hs.InfixL
888      cvt_dir TH.InfixR = Hs.InfixR
889      cvt_dir TH.InfixN = Hs.InfixN
890
891 -----------------------------------------------------------
892
893
894 -----------------------------------------------------------
895 -- some useful things
896
897 overloadedLit :: Lit -> Bool
898 -- True for literals that Haskell treats as overloaded
899 overloadedLit (IntegerL  _) = True
900 overloadedLit (RationalL _) = True
901 overloadedLit _             = False
902
903 void :: Type.Type
904 void = placeHolderType
905
906 cvtFractionalLit :: Rational -> FractionalLit
907 cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
908
909 --------------------------------------------------------------------
910 --      Turning Name back into RdrName
911 --------------------------------------------------------------------
912
913 -- variable names
914 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
915 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
916
917 vNameL n = wrapL (vName n)
918 vName n = cvtName OccName.varName n
919
920 -- Constructor function names; this is Haskell source, hence srcDataName
921 cNameL n = wrapL (cName n)
922 cName n = cvtName OccName.dataName n 
923
924 -- Type variable names
925 tName n = cvtName OccName.tvName n
926
927 -- Type Constructor names
928 tconNameL n = wrapL (tconName n)
929 tconName n = cvtName OccName.tcClsName n
930
931 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
932 cvtName ctxt_ns (TH.Name occ flavour)
933   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
934   | otherwise                   
935   = do { loc <- getL
936        ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour 
937        ; force rdr_name 
938        ; return rdr_name }
939   where
940     occ_str = TH.occString occ
941
942 okOcc :: OccName.NameSpace -> String -> Bool
943 okOcc _  []      = False
944 okOcc ns str@(c:_) 
945   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
946   | otherwise                 = startsConId c || startsConSym c || str == "[]"
947
948 -- Determine the name space of a name in a type
949 --
950 isVarName :: TH.Name -> Bool
951 isVarName (TH.Name occ _)
952   = case TH.occString occ of
953       ""    -> False
954       (c:_) -> startsVarId c || startsVarSym c
955
956 badOcc :: OccName.NameSpace -> String -> SDoc
957 badOcc ctxt_ns occ 
958   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
959         <+> ptext (sLit "name:") <+> quotes (text occ)
960
961 thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
962 -- This turns a TH Name into a RdrName; used for both binders and occurrences
963 -- See Note [Binders in Template Haskell]
964 -- The passed-in name space tells what the context is expecting;
965 --      use it unless the TH name knows what name-space it comes
966 --      from, in which case use the latter
967 --
968 -- We pass in a SrcSpan (gotten from the monad) because this function
969 -- is used for *binders* and if we make an Exact Name we want it
970 -- to have a binding site inside it.  (cf Trac #5434)
971 --
972 -- ToDo: we may generate silly RdrNames, by passing a name space
973 --       that doesn't match the string, like VarName ":+", 
974 --       which will give confusing error messages later
975 -- 
976 -- The strict applications ensure that any buried exceptions get forced
977 thRdrName loc ctxt_ns th_occ th_name
978   = case th_name of
979      TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
980      TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ
981      TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
982      TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
983      TH.NameS | Just name <- isBuiltInOcc ctxt_ns th_occ -> nameRdrName $! name
984               | otherwise                                -> mkRdrUnqual $! occ
985   where
986     occ :: OccName.OccName
987     occ = mk_occ ctxt_ns th_occ
988
989 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
990 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
991
992 thRdrNameGuesses :: TH.Name -> [RdrName]
993 thRdrNameGuesses (TH.Name occ flavour)
994   -- This special case for NameG ensures that we don't generate duplicates in the output list
995   | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
996   | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour
997                                         | gns <- guessed_nss]
998   where
999     -- guessed_ns are the name spaces guessed from looking at the TH name
1000     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
1001                 | otherwise                       = [OccName.varName, OccName.tvName]
1002     occ_str = TH.occString occ
1003
1004 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
1005 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
1006 -- We must generate an Exact name, just as the parser does
1007 isBuiltInOcc ctxt_ns occ
1008   = case occ of
1009         ":"              -> Just (Name.getName consDataCon)
1010         "[]"             -> Just (Name.getName nilDataCon)
1011         "()"             -> Just (tup_name 0)
1012         '(' : ',' : rest -> go_tuple 2 rest
1013         _                -> Nothing
1014   where
1015     go_tuple n ")"          = Just (tup_name n)
1016     go_tuple n (',' : rest) = go_tuple (n+1) rest
1017     go_tuple _ _            = Nothing
1018
1019     tup_name n 
1020         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon BoxedTuple n)
1021         | otherwise                        = Name.getName (tupleCon BoxedTuple n)
1022
1023 -- The packing and unpacking is rather turgid :-(
1024 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
1025 mk_occ ns occ = OccName.mkOccName ns occ
1026
1027 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
1028 mk_ghc_ns TH.DataName  = OccName.dataName
1029 mk_ghc_ns TH.TcClsName = OccName.tcClsName
1030 mk_ghc_ns TH.VarName   = OccName.varName
1031
1032 mk_mod :: TH.ModName -> ModuleName
1033 mk_mod mod = mkModuleName (TH.modString mod)
1034
1035 mk_pkg :: TH.PkgName -> PackageId
1036 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
1037
1038 mk_uniq :: Int# -> Unique
1039 mk_uniq u = mkUniqueGrimily (I# u)
1040 \end{code}
1041
1042 Note [Binders in Template Haskell]
1043 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1044 Consider this TH term construction:
1045   do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name
1046      ; x2 <- TH.newName "x"   -- Builds a NameU
1047      ; x3 <- TH.newName "x"
1048
1049      ; let x = mkName "x"     -- mkName :: String -> TH.Name
1050                               -- Builds a NameL
1051
1052      ; return (LamE (..pattern [x1,x2]..) $
1053                LamE (VarPat x3) $
1054                ..tuple (x1,x2,x3,x)) }
1055
1056 It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)
1057
1058 a) We don't want to complain about "x" being bound twice in 
1059    the pattern [x1,x2]
1060 b) We don't want x3 to shadow the x1,x2
1061 c) We *do* want 'x' (dynamically bound with mkName) to bind 
1062    to the innermost binding of "x", namely x3.
1063 d) When pretty printing, we want to print a unique with x1,x2 
1064    etc, else they'll all print as "x" which isn't very helpful
1065
1066 When we convert all this to HsSyn, the TH.Names are converted with
1067 thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.
1068 Achieving (a) is a bit awkward, because
1069    - We must check for duplicate and shadowed names on Names, 
1070      not RdrNames, *after* renaming.   
1071      See Note [Collect binders only after renaming] in HsUtils
1072
1073    - But to achieve (a) we must distinguish between the Exact
1074      RdrNames arising from TH and the Unqual RdrNames that would
1075      come from a user writing \[x,x] -> blah
1076
1077 So in Convert.thRdrName we translate
1078    TH Name                          RdrName
1079    --------------------------------------------------------
1080    NameU (arising from newName) --> Exact (Name{ System })
1081    NameS (arising from mkName)  --> Unqual
1082
1083 Notice that the NameUs generate *System* Names.  Then, when
1084 figuring out shadowing and duplicates, we can filter out
1085 System Names.
1086
1087 This use of System Names fits with other uses of System Names, eg for
1088 temporary variables "a". Since there are lots of things called "a" we
1089 usually want to print the name with the unique, and that is indeed
1090 the way System Names are printed.
1091
1092 There's a small complication of course; see Note [Looking up Exact
1093 RdrNames] in RnEnv.