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