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