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