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