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