Wibbles to lunaris's patch for promoted kinds
[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' <- tconName nm; mk_apps (HsTyVar nm') tys' }
865
866            PromotedTupleT n
867              | n == 1
868              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
869              | m == n   -- Saturated
870              -> do  { let kis = replicate m placeHolderKind
871                     ; returnL (HsExplicitTupleTy kis tys')
872                     }
873              where
874                m = length tys'
875
876            PromotedNilT
877              -> returnL (HsExplicitListTy placeHolderKind [])
878
879            PromotedConsT  -- See Note [Representing concrete syntax in types] 
880                           -- in Language.Haskell.TH.Syntax
881              | [ty1, L _ (HsExplicitListTy _ tys2)] <- tys'
882              -> returnL (HsExplicitListTy placeHolderKind (ty1:tys2))
883              | otherwise 
884              -> mk_apps (HsTyVar (getRdrName consDataCon)) tys'
885
886            StarT
887              -> returnL (HsTyVar (getRdrName liftedTypeKindTyCon))
888
889            ConstraintT
890              -> returnL (HsTyVar (getRdrName constraintKindTyCon))
891
892            _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
893     }
894
895 mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
896 mk_apps head_ty []       = returnL head_ty
897 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
898                               ; mk_apps (HsAppTy head_ty' ty) tys }
899
900 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
901 split_ty_app ty = go ty []
902   where
903     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
904     go f as           = return (f,as)
905
906 cvtTyLit :: TH.TyLit -> HsTyLit
907 cvtTyLit (NumTyLit i) = HsNumTy i
908 cvtTyLit (StrTyLit s) = HsStrTy (fsLit s)
909
910 cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
911 cvtKind = cvtTypeKind "kind"
912
913 cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
914 cvtMaybeKind Nothing = return Nothing
915 cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
916                             ; return (Just ki') }
917
918 -----------------------------------------------------------
919 cvtFixity :: TH.Fixity -> Hs.Fixity
920 cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir)
921    where
922      cvt_dir TH.InfixL = Hs.InfixL
923      cvt_dir TH.InfixR = Hs.InfixR
924      cvt_dir TH.InfixN = Hs.InfixN
925
926 -----------------------------------------------------------
927
928
929 -----------------------------------------------------------
930 -- some useful things
931
932 overloadedLit :: Lit -> Bool
933 -- True for literals that Haskell treats as overloaded
934 overloadedLit (IntegerL  _) = True
935 overloadedLit (RationalL _) = True
936 overloadedLit _             = False
937
938 void :: Type.Type
939 void = placeHolderType
940
941 cvtFractionalLit :: Rational -> FractionalLit
942 cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
943
944 --------------------------------------------------------------------
945 --      Turning Name back into RdrName
946 --------------------------------------------------------------------
947
948 -- variable names
949 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
950 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
951
952 vNameL n = wrapL (vName n)
953 vName n = cvtName OccName.varName n
954
955 -- Constructor function names; this is Haskell source, hence srcDataName
956 cNameL n = wrapL (cName n)
957 cName n = cvtName OccName.dataName n
958
959 -- Type variable names
960 tName n = cvtName OccName.tvName n
961
962 -- Type Constructor names
963 tconNameL n = wrapL (tconName n)
964 tconName n = cvtName OccName.tcClsName n
965
966 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
967 cvtName ctxt_ns (TH.Name occ flavour)
968   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
969   | otherwise
970   = do { loc <- getL
971        ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
972        ; force rdr_name
973        ; return rdr_name }
974   where
975     occ_str = TH.occString occ
976
977 okOcc :: OccName.NameSpace -> String -> Bool
978 okOcc _  []      = False
979 okOcc ns str@(c:_)
980   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
981   | otherwise                 = startsConId c || startsConSym c || str == "[]"
982
983 -- Determine the name space of a name in a type
984 --
985 isVarName :: TH.Name -> Bool
986 isVarName (TH.Name occ _)
987   = case TH.occString occ of
988       ""    -> False
989       (c:_) -> startsVarId c || startsVarSym c
990
991 badOcc :: OccName.NameSpace -> String -> SDoc
992 badOcc ctxt_ns occ
993   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
994         <+> ptext (sLit "name:") <+> quotes (text occ)
995
996 thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
997 -- This turns a TH Name into a RdrName; used for both binders and occurrences
998 -- See Note [Binders in Template Haskell]
999 -- The passed-in name space tells what the context is expecting;
1000 --      use it unless the TH name knows what name-space it comes
1001 --      from, in which case use the latter
1002 --
1003 -- We pass in a SrcSpan (gotten from the monad) because this function
1004 -- is used for *binders* and if we make an Exact Name we want it
1005 -- to have a binding site inside it.  (cf Trac #5434)
1006 --
1007 -- ToDo: we may generate silly RdrNames, by passing a name space
1008 --       that doesn't match the string, like VarName ":+",
1009 --       which will give confusing error messages later
1010 --
1011 -- The strict applications ensure that any buried exceptions get forced
1012 thRdrName loc ctxt_ns th_occ th_name
1013   = case th_name of
1014      TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
1015      TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ
1016      TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
1017      TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
1018      TH.NameS | Just name <- isBuiltInOcc ctxt_ns th_occ -> nameRdrName $! name
1019               | otherwise                                -> mkRdrUnqual $! occ
1020   where
1021     occ :: OccName.OccName
1022     occ = mk_occ ctxt_ns th_occ
1023
1024 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
1025 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
1026
1027 thRdrNameGuesses :: TH.Name -> [RdrName]
1028 thRdrNameGuesses (TH.Name occ flavour)
1029   -- This special case for NameG ensures that we don't generate duplicates in the output list
1030   | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
1031   | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour
1032                                         | gns <- guessed_nss]
1033   where
1034     -- guessed_ns are the name spaces guessed from looking at the TH name
1035     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
1036                 | otherwise                       = [OccName.varName, OccName.tvName]
1037     occ_str = TH.occString occ
1038
1039 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
1040 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
1041 -- We must generate an Exact name, just as the parser does
1042 isBuiltInOcc ctxt_ns occ
1043   = case occ of
1044         ":"              -> Just (Name.getName consDataCon)
1045         "[]"             -> Just (Name.getName nilDataCon)
1046         "()"             -> Just (tup_name 0)
1047         '(' : ',' : rest -> go_tuple 2 rest
1048         _                -> Nothing
1049   where
1050     go_tuple n ")"          = Just (tup_name n)
1051     go_tuple n (',' : rest) = go_tuple (n+1) rest
1052     go_tuple _ _            = Nothing
1053
1054     tup_name n
1055         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon BoxedTuple n)
1056         | otherwise                        = Name.getName (tupleCon BoxedTuple n)
1057
1058 -- The packing and unpacking is rather turgid :-(
1059 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
1060 mk_occ ns occ = OccName.mkOccName ns occ
1061
1062 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
1063 mk_ghc_ns TH.DataName  = OccName.dataName
1064 mk_ghc_ns TH.TcClsName = OccName.tcClsName
1065 mk_ghc_ns TH.VarName   = OccName.varName
1066
1067 mk_mod :: TH.ModName -> ModuleName
1068 mk_mod mod = mkModuleName (TH.modString mod)
1069
1070 mk_pkg :: TH.PkgName -> PackageId
1071 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
1072
1073 mk_uniq :: Int# -> Unique
1074 mk_uniq u = mkUniqueGrimily (I# u)
1075 \end{code}
1076
1077 Note [Binders in Template Haskell]
1078 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1079 Consider this TH term construction:
1080   do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name
1081      ; x2 <- TH.newName "x"   -- Builds a NameU
1082      ; x3 <- TH.newName "x"
1083
1084      ; let x = mkName "x"     -- mkName :: String -> TH.Name
1085                               -- Builds a NameL
1086
1087      ; return (LamE (..pattern [x1,x2]..) $
1088                LamE (VarPat x3) $
1089                ..tuple (x1,x2,x3,x)) }
1090
1091 It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)
1092
1093 a) We don't want to complain about "x" being bound twice in
1094    the pattern [x1,x2]
1095 b) We don't want x3 to shadow the x1,x2
1096 c) We *do* want 'x' (dynamically bound with mkName) to bind
1097    to the innermost binding of "x", namely x3.
1098 d) When pretty printing, we want to print a unique with x1,x2
1099    etc, else they'll all print as "x" which isn't very helpful
1100
1101 When we convert all this to HsSyn, the TH.Names are converted with
1102 thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.
1103 Achieving (a) is a bit awkward, because
1104    - We must check for duplicate and shadowed names on Names,
1105      not RdrNames, *after* renaming.
1106      See Note [Collect binders only after renaming] in HsUtils
1107
1108    - But to achieve (a) we must distinguish between the Exact
1109      RdrNames arising from TH and the Unqual RdrNames that would
1110      come from a user writing \[x,x] -> blah
1111
1112 So in Convert.thRdrName we translate
1113    TH Name                          RdrName
1114    --------------------------------------------------------
1115    NameU (arising from newName) --> Exact (Name{ System })
1116    NameS (arising from mkName)  --> Unqual
1117
1118 Notice that the NameUs generate *System* Names.  Then, when
1119 figuring out shadowing and duplicates, we can filter out
1120 System Names.
1121
1122 This use of System Names fits with other uses of System Names, eg for
1123 temporary variables "a". Since there are lots of things called "a" we
1124 usually want to print the name with the unique, and that is indeed
1125 the way System Names are printed.
1126
1127 There's a small complication of course; see Note [Looking up Exact
1128 RdrNames] in RnEnv.