Add tuple sections as a new feature
[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 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
10                 convertToHsType, thRdrNameGuesses ) where
11
12 import HsSyn as Hs
13 import qualified Class
14 import RdrName
15 import qualified Name
16 import Module
17 import RdrHsSyn
18 import qualified OccName
19 import OccName
20 import SrcLoc
21 import Type
22 import TysWiredIn
23 import BasicTypes as Hs
24 import ForeignCall
25 import Char
26 import List
27 import Unique
28 import MonadUtils
29 import ErrUtils
30 import Bag
31 import FastString
32 import Outputable
33
34 import Language.Haskell.TH as TH hiding (sigP)
35 import Language.Haskell.TH.Syntax as TH
36
37 import GHC.Exts
38
39 -------------------------------------------------------------------
40 --              The external interface
41
42 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]
43 convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds)
44
45 convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
46 convertToHsExpr loc e 
47   = case initCvt loc (cvtl e) of
48         Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH expression:")
49                                     <+> text (show e)))
50         Right res -> Right res
51
52 convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName)
53 convertToPat loc e
54   = case initCvt loc (cvtPat e) of
55         Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH pattern:")
56                                     <+> text (show e)))
57         Right res -> Right res
58
59 convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
60 convertToHsType loc t = initCvt loc (cvtType t)
61
62
63 -------------------------------------------------------------------
64 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
65         -- Push down the source location;
66         -- Can fail, with a single error message
67
68 -- NB: If the conversion succeeds with (Right x), there should 
69 --     be no exception values hiding in x
70 -- Reason: so a (head []) in TH code doesn't subsequently
71 --         make GHC crash when it tries to walk the generated tree
72
73 -- Use the loc everywhere, for lack of anything better
74 -- In particular, we want it on binding locations, so that variables bound in
75 -- the spliced-in declarations get a location that at least relates to the splice point
76
77 instance Monad CvtM where
78   return x       = CvtM $ \_   -> Right x
79   (CvtM m) >>= k = CvtM $ \loc -> case m loc of
80                                     Left err -> Left err
81                                     Right v  -> unCvtM (k v) loc
82
83 initCvt :: SrcSpan -> CvtM a -> Either Message a
84 initCvt loc (CvtM m) = m loc
85
86 force :: a -> CvtM ()
87 force a = a `seq` return ()
88
89 failWith :: Message -> CvtM a
90 failWith m = CvtM (\_ -> Left full_msg)
91    where
92      full_msg = m $$ ptext (sLit "When splicing generated code into the program")
93
94 returnL :: a -> CvtM (Located a)
95 returnL x = CvtM (\loc -> Right (L loc x))
96
97 wrapL :: CvtM a -> CvtM (Located a)
98 wrapL (CvtM m) = CvtM (\loc -> case m loc of
99                           Left err -> Left err
100                           Right v  -> Right (L loc v))
101
102 -------------------------------------------------------------------
103 cvtTop :: TH.Dec -> CvtM (LHsDecl RdrName)
104 cvtTop d@(TH.ValD _ _ _) 
105   = do { L loc d' <- cvtBind d
106        ; return (L loc $ Hs.ValD d') }
107
108 cvtTop d@(TH.FunD _ _)   
109   = do { L loc d' <- cvtBind d
110        ; return (L loc $ Hs.ValD d') }
111
112 cvtTop (TH.SigD nm typ)  
113   = do  { nm' <- vNameL nm
114         ; ty' <- cvtType typ
115         ; returnL $ Hs.SigD (TypeSig nm' ty') }
116
117 cvtTop (TySynD tc tvs rhs)
118   = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
119         ; rhs' <- cvtType rhs
120         ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
121
122 cvtTop (DataD ctxt tc tvs constrs derivs)
123   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
124         ; cons' <- mapM cvtConstr constrs
125         ; derivs' <- cvtDerivs derivs
126         ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
127                                   , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
128                                   , tcdCons = cons', tcdDerivs = derivs' }) }
129
130 cvtTop (NewtypeD ctxt tc tvs constr derivs)
131   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
132         ; con' <- cvtConstr constr
133         ; derivs' <- cvtDerivs derivs
134         ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
135                                   , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
136                                   , tcdCons = [con'], tcdDerivs = derivs'}) }
137
138 cvtTop (ClassD ctxt cl tvs fds decs)
139   = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
140         ; fds'  <- mapM cvt_fundep fds
141         ; let (ats, bind_sig_decs) = partition isFamilyD decs
142         ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
143         ; ats' <- mapM cvtTop ats
144         ; let ats'' = map unTyClD ats'
145         ; returnL $ 
146             TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
147                               , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
148                               , tcdATs = ats'', tcdDocs = [] }
149                                                         -- no docs in TH ^^
150         }
151   where
152     isFamilyD (FamilyD _ _ _ _) = True
153     isFamilyD _                 = False
154
155 cvtTop (InstanceD ctxt ty decs)
156   = do  { let (ats, bind_sig_decs) = partition isFamInstD decs
157         ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
158         ; ats' <- mapM cvtTop ats
159         ; let ats'' = map unTyClD ats'
160         ; ctxt' <- cvtContext ctxt
161         ; L loc pred' <- cvtPredTy ty
162         ; inst_ty' <- returnL $ 
163                         mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
164         ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats'')
165         }
166   where
167     isFamInstD (DataInstD _ _ _ _ _)    = True
168     isFamInstD (NewtypeInstD _ _ _ _ _) = True
169     isFamInstD (TySynInstD _ _ _)       = True
170     isFamInstD _                        = False
171
172 cvtTop (ForeignD ford) 
173   = do { ford' <- cvtForD ford
174        ; returnL $ ForD ford' 
175        }
176
177 cvtTop (PragmaD prag)
178   = do { prag' <- cvtPragmaD prag
179        ; returnL $ Hs.SigD prag'
180        }
181
182 cvtTop (FamilyD flav tc tvs kind)
183   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
184        ; let kind' = fmap cvtKind kind
185        ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind')
186        }
187   where
188     cvtFamFlavour TypeFam = TypeFamily
189     cvtFamFlavour DataFam = DataFamily
190
191 cvtTop (DataInstD ctxt tc tys constrs derivs)
192   = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
193        ; cons' <- mapM cvtConstr constrs
194        ; derivs' <- cvtDerivs derivs
195        ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
196                                   , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
197                                   , tcdCons = cons', tcdDerivs = derivs' })
198        }
199
200 cvtTop (NewtypeInstD ctxt tc tys constr derivs)
201   = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
202        ; con' <- cvtConstr constr
203        ; derivs' <- cvtDerivs derivs
204        ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
205                                   , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
206                                   , tcdCons = [con'], tcdDerivs = derivs' })
207        }
208
209 cvtTop (TySynInstD tc tys rhs)
210   = do  { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
211         ; rhs' <- cvtType rhs
212         ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
213
214 -- FIXME: This projection is not nice, but to remove it, cvtTop should be 
215 --        refactored.
216 unTyClD :: LHsDecl a -> LTyClDecl a
217 unTyClD (L l (TyClD d)) = L l d
218 unTyClD _               = panic "Convert.unTyClD: internal error"
219
220 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
221              -> CvtM ( LHsContext RdrName
222                      , Located RdrName
223                      , [LHsTyVarBndr RdrName])
224 cvt_tycl_hdr cxt tc tvs
225   = do { cxt' <- cvtContext cxt
226        ; tc'  <- tconNameL tc
227        ; tvs' <- cvtTvs tvs
228        ; return (cxt', tc', tvs') 
229        }
230
231 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
232                -> CvtM ( LHsContext RdrName
233                        , Located RdrName
234                        , [LHsTyVarBndr RdrName]
235                        , Maybe [LHsType RdrName])
236 cvt_tyinst_hdr cxt tc tys
237   = do { cxt' <- cvtContext cxt
238        ; tc'  <- tconNameL tc
239        ; tvs  <- concatMapM collect tys
240        ; tvs' <- cvtTvs tvs
241        ; tys' <- mapM cvtType tys
242        ; return (cxt', tc', tvs', Just tys') 
243        }
244   where
245     collect (ForallT _ _ _) 
246       = failWith $ text "Forall type not allowed as type parameter"
247     collect (VarT tv)    = return [PlainTV tv]
248     collect (ConT _)     = return []
249     collect (TupleT _)   = return []
250     collect ArrowT       = return []
251     collect ListT        = return []
252     collect (AppT t1 t2)
253       = do { tvs1 <- collect t1
254            ; tvs2 <- collect t2
255            ; return $ tvs1 ++ tvs2
256            }
257     collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
258     collect (SigT ty _)         = collect ty
259
260 ---------------------------------------------------
261 --      Data types
262 -- Can't handle GADTs yet
263 ---------------------------------------------------
264
265 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
266
267 cvtConstr (NormalC c strtys)
268   = do  { c'   <- cNameL c 
269         ; cxt' <- returnL []
270         ; tys' <- mapM cvt_arg strtys
271         ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
272
273 cvtConstr (RecC c varstrtys)
274   = do  { c'    <- cNameL c 
275         ; cxt'  <- returnL []
276         ; args' <- mapM cvt_id_arg varstrtys
277         ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
278
279 cvtConstr (InfixC st1 c st2)
280   = do  { c' <- cNameL c 
281         ; cxt' <- returnL []
282         ; st1' <- cvt_arg st1
283         ; st2' <- cvt_arg st2
284         ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
285
286 cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
287   = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
288
289 cvtConstr (ForallC tvs ctxt con)
290   = do  { L _ con' <- cvtConstr con
291         ; tvs'  <- cvtTvs tvs
292         ; ctxt' <- cvtContext ctxt
293         ; case con' of
294             ConDecl { con_qvars = [], con_cxt = L _ [] }
295               -> returnL $ con' { con_qvars = tvs', con_cxt = ctxt' }
296             _ -> panic "ForallC: Can't happen" }
297
298 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
299 cvt_arg (IsStrict, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
300 cvt_arg (NotStrict, ty) = cvtType ty
301
302 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
303 cvt_id_arg (i, str, ty) 
304   = do  { i' <- vNameL i
305         ; ty' <- cvt_arg (str,ty)
306         ; return (ConDeclField { cd_fld_name = i', cd_fld_type =  ty', cd_fld_doc = Nothing}) }
307
308 cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
309 cvtDerivs [] = return Nothing
310 cvtDerivs cs = do { cs' <- mapM cvt_one cs
311                   ; return (Just cs') }
312         where
313           cvt_one c = do { c' <- tconName c
314                          ; returnL $ HsPredTy $ HsClassP c' [] }
315
316 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
317 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
318
319 noExistentials :: [LHsTyVarBndr RdrName]
320 noExistentials = []
321
322 ------------------------------------------
323 --      Foreign declarations
324 ------------------------------------------
325
326 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
327 cvtForD (ImportF callconv safety from nm ty)
328   | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from
329   = do  { nm' <- vNameL nm
330         ; ty' <- cvtType ty
331         ; let i = CImport (cvt_conv callconv) safety' c_header cis
332         ; return $ ForeignImport nm' ty' i }
333
334   | otherwise
335   = failWith $ text (show from)<+> ptext (sLit "is not a valid ccall impent")
336   where 
337     safety' = case safety of
338                      Unsafe     -> PlayRisky
339                      Safe       -> PlaySafe False
340                      Threadsafe -> PlaySafe True
341
342 cvtForD (ExportF callconv as nm ty)
343   = do  { nm' <- vNameL nm
344         ; ty' <- cvtType ty
345         ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
346         ; return $ ForeignExport nm' ty' e }
347
348 cvt_conv :: TH.Callconv -> CCallConv
349 cvt_conv TH.CCall   = CCallConv
350 cvt_conv TH.StdCall = StdCallConv
351
352 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
353 parse_ccall_impent nm s
354  = case lex_ccall_impent s of
355        Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
356        Just ["wrapper"] -> Just (nilFS, CWrapper)
357        Just ("static":ts) -> parse_ccall_impent_static nm ts
358        Just ts -> parse_ccall_impent_static nm ts
359        Nothing -> Nothing
360
361 -- XXX we should be sharing code with RdrHsSyn.parseCImport
362 parse_ccall_impent_static :: String
363                           -> [String]
364                           -> Maybe (FastString, CImportSpec)
365 parse_ccall_impent_static nm ts
366  = case ts of
367      [               ] -> mkFun nilFS                 nm
368      [       "&", cid] -> mkLbl nilFS                 cid
369      [fname, "&"     ] -> mkLbl (mkFastString fname)  nm
370      [fname, "&", cid] -> mkLbl (mkFastString fname)  cid
371      [       "&"     ] -> mkLbl nilFS                 nm
372      [fname,      cid] -> mkFun (mkFastString fname)  cid
373      [            cid]
374           | is_cid cid -> mkFun nilFS                 cid
375           | otherwise  -> mkFun (mkFastString cid)    nm
376            -- tricky case when there's a single string: "foo.h" is a header,
377            -- but "foo" is a C identifier, and we tell the difference by
378            -- checking for a valid C identifier (see is_cid below).
379      _anything_else    -> Nothing
380
381     where is_cid :: String -> Bool
382           is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
383
384           mkLbl :: FastString -> String -> Maybe (FastString, CImportSpec)
385           mkLbl fname lbl  = Just (fname, CLabel (mkFastString lbl))
386
387           mkFun :: FastString -> String -> Maybe (FastString, CImportSpec)
388           mkFun fname lbl  = Just (fname, CFunction (StaticTarget (mkFastString lbl)))
389
390 -- This code is tokenising something like "foo.h &bar", eg.
391 --   ""           -> Just []
392 --   "foo.h"      -> Just ["foo.h"]
393 --   "foo.h &bar" -> Just ["foo.h","&","bar"]
394 --   "&"          -> Just ["&"]
395 -- Nothing is returned for a parse error.
396 lex_ccall_impent :: String -> Maybe [String]
397 lex_ccall_impent "" = Just []
398 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
399 lex_ccall_impent (' ':xs) = lex_ccall_impent xs
400 lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
401 lex_ccall_impent xs = case span is_valid xs of
402                           ("", _) -> Nothing
403                           (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
404     where is_valid :: Char -> Bool
405           is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
406
407 ------------------------------------------
408 --              Pragmas
409 ------------------------------------------
410
411 cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
412 cvtPragmaD (InlineP nm ispec)
413   = do { nm'    <- vNameL nm
414        ; return $ InlineSig nm' (cvtInlineSpec (Just ispec))
415        }
416 cvtPragmaD (SpecialiseP nm ty opt_ispec)
417   = do { nm'    <- vNameL nm
418        ; ty'    <- cvtType ty
419        ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec)
420        }
421
422 cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlineSpec
423 cvtInlineSpec Nothing 
424   = defaultInlineSpec
425 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) 
426   = mkInlineSpec opt_activation' matchinfo inline
427   where
428     matchinfo       = cvtRuleMatchInfo conlike
429     opt_activation' = fmap cvtActivation opt_activation
430
431     cvtRuleMatchInfo False = FunLike
432     cvtRuleMatchInfo True  = ConLike
433
434     cvtActivation (False, phase) = ActiveBefore phase
435     cvtActivation (True , phase) = ActiveAfter  phase
436
437 ---------------------------------------------------
438 --              Declarations
439 ---------------------------------------------------
440
441 cvtDecs :: [TH.Dec] -> CvtM (HsLocalBinds RdrName)
442 cvtDecs [] = return EmptyLocalBinds
443 cvtDecs ds = do { (binds, sigs) <- cvtBindsAndSigs ds
444                 ; return (HsValBinds (ValBindsIn binds sigs)) }
445
446 cvtBindsAndSigs :: [TH.Dec] -> CvtM (Bag (LHsBind RdrName), [LSig RdrName])
447 cvtBindsAndSigs ds 
448   = do { binds' <- mapM cvtBind binds
449        ; sigs' <- mapM cvtSig sigs
450        ; return (listToBag binds', sigs') }
451   where 
452     (sigs, binds) = partition is_sig ds
453
454     is_sig (TH.SigD _ _)  = True
455     is_sig (TH.PragmaD _) = True
456     is_sig _              = False
457
458 cvtSig :: TH.Dec -> CvtM (LSig RdrName)
459 cvtSig (TH.SigD nm ty)
460   = do { nm' <- vNameL nm
461        ; ty' <- cvtType ty
462        ; returnL (Hs.TypeSig nm' ty') 
463        }
464 cvtSig (TH.PragmaD prag)
465   = do { prag' <- cvtPragmaD prag
466        ; returnL prag'
467        }
468 cvtSig _ = panic "Convert.cvtSig: Signature expected"
469
470 cvtBind :: TH.Dec -> CvtM (LHsBind RdrName)
471 -- Used only for declarations in a 'let/where' clause,
472 -- not for top level decls
473 cvtBind (TH.ValD (TH.VarP s) body ds) 
474   = do  { s' <- vNameL s
475         ; cl' <- cvtClause (Clause [] body ds)
476         ; returnL $ mkFunBind s' [cl'] }
477
478 cvtBind (TH.FunD nm cls)
479   | null cls
480   = failWith (ptext (sLit "Function binding for")
481                     <+> quotes (text (TH.pprint nm))
482                     <+> ptext (sLit "has no equations"))
483   | otherwise
484   = do  { nm' <- vNameL nm
485         ; cls' <- mapM cvtClause cls
486         ; returnL $ mkFunBind nm' cls' }
487
488 cvtBind (TH.ValD p body ds)
489   = do  { p' <- cvtPat p
490         ; g' <- cvtGuard body
491         ; ds' <- cvtDecs ds
492         ; returnL $ PatBind { pat_lhs = p', pat_rhs = GRHSs g' ds', 
493                               pat_rhs_ty = void, bind_fvs = placeHolderNames } }
494
495 cvtBind d 
496   = failWith (sep [ptext (sLit "Illegal kind of declaration in where clause"),
497                    nest 2 (text (TH.pprint d))])
498
499 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
500 cvtClause (Clause ps body wheres)
501   = do  { ps' <- cvtPats ps
502         ; g'  <- cvtGuard body
503         ; ds' <- cvtDecs wheres
504         ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
505
506
507 -------------------------------------------------------------------
508 --              Expressions
509 -------------------------------------------------------------------
510
511 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
512 cvtl e = wrapL (cvt e)
513   where
514     cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
515     cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
516     cvt (LitE l) 
517       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
518       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
519
520     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
521     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e 
522                             ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
523     cvt (TupE [e])     = cvt e  -- Singleton tuples treated like nothing (just parens)
524     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
525     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
526                             ; return $ HsIf x' y' z' }
527     cvt (LetE ds e)    = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
528     cvt (CaseE e ms)   
529        | null ms       = failWith (ptext (sLit "Case expression with no alternatives"))
530        | otherwise     = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
531                             ; return $ HsCase e' (mkMatchGroup ms') }
532     cvt (DoE ss)       = cvtHsDo DoExpr ss
533     cvt (CompE ss)     = cvtHsDo ListComp ss
534     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
535     cvt (ListE xs)     
536       | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
537              -- Note [Converting strings]
538       | otherwise                    = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
539     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
540                                           ; e' <- returnL $ OpApp x' s' undefined y'
541                                           ; return $ HsPar e' }
542     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
543                                           ; sec <- returnL $ SectionR s' y'
544                                           ; return $ HsPar sec }
545     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
546                                           ; sec <- returnL $ SectionL x' s'
547                                           ; return $ HsPar sec }
548     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
549
550     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
551                               ; return $ ExprWithTySig e' t' }
552     cvt (RecConE c flds) = do { c' <- cNameL c
553                               ; flds' <- mapM cvtFld flds
554                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
555     cvt (RecUpdE e flds) = do { e' <- cvtl e
556                               ; flds' <- mapM cvtFld flds
557                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
558
559 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
560 cvtFld (v,e) 
561   = do  { v' <- vNameL v; e' <- cvtl e
562         ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
563
564 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
565 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
566 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
567 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
568 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
569
570 -------------------------------------
571 --      Do notation and statements
572 -------------------------------------
573
574 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
575 cvtHsDo do_or_lc stmts
576   | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
577   | otherwise
578   = do  { stmts' <- cvtStmts stmts
579         ; let body = case last stmts' of
580                         L _ (ExprStmt body _ _) -> body
581                         _                       -> panic "Malformed body"
582         ; return $ HsDo do_or_lc (init stmts') body void }
583
584 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
585 cvtStmts = mapM cvtStmt 
586
587 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
588 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
589 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
590 cvtStmt (TH.LetS ds)   = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' }
591 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
592                        where
593                          cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
594
595 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
596 cvtMatch (TH.Match p body decs)
597   = do  { p' <- cvtPat p
598         ; g' <- cvtGuard body
599         ; decs' <- cvtDecs decs
600         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
601
602 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
603 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
604 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
605
606 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
607 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
608                               ; g' <- returnL $ mkExprStmt ge'
609                               ; returnL $ GRHS [g'] rhs' }
610 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
611                               ; returnL $ GRHS gs' rhs' }
612
613 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
614 cvtOverLit (IntegerL i)  
615   = do { force i; return $ mkHsIntegral i placeHolderType}
616 cvtOverLit (RationalL r) 
617   = do { force r; return $ mkHsFractional r placeHolderType}
618 cvtOverLit (StringL s)   
619   = do { let { s' = mkFastString s }
620        ; force s'
621        ; return $ mkHsIsString s' placeHolderType 
622        }
623 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
624 -- An Integer is like an (overloaded) '3' in a Haskell source program
625 -- Similarly 3.5 for fractionals
626
627 {- Note [Converting strings] 
628 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
629 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
630 a string literal for "xy".  Of course, we might hope to get 
631 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
632 if it isn't a literal string
633 -}
634
635 allCharLs :: [TH.Exp] -> Maybe String
636 -- Note [Converting strings]
637 allCharLs (LitE (CharL c) : xs) 
638   | Just cs <- allCharLs xs = Just (c:cs)
639 allCharLs [] = Just []
640 allCharLs _  = Nothing
641
642 cvtLit :: Lit -> CvtM HsLit
643 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
644 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
645 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
646 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
647 cvtLit (CharL c)       = do { force c; return $ HsChar c }
648 cvtLit (StringL s)     
649   = do { let { s' = mkFastString s }
650        ; force s'
651        ; return $ HsString s' 
652        }
653 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
654
655 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
656 cvtPats pats = mapM cvtPat pats
657
658 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
659 cvtPat pat = wrapL (cvtp pat)
660
661 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
662 cvtp (TH.LitP l)
663   | overloadedLit l   = do { l' <- cvtOverLit l
664                            ; return (mkNPat l' Nothing) }
665                                   -- Not right for negative patterns; 
666                                   -- need to think about that!
667   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
668 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
669 cvtp (TupP [p])       = cvtp p
670 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
671 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
672 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
673                            ; return $ ConPatIn s' (InfixCon p1' p2') }
674 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
675 cvtp (BangP p)        = do { p' <- cvtPat p; return $ BangPat p' }
676 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
677 cvtp TH.WildP         = return $ WildPat void
678 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs 
679                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
680 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
681 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
682
683 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
684 cvtPatFld (s,p)
685   = do  { s' <- vNameL s; p' <- cvtPat p
686         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
687
688 -----------------------------------------------------------
689 --      Types and type variables
690
691 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
692 cvtTvs tvs = mapM cvt_tv tvs
693
694 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
695 cvt_tv (TH.PlainTV nm) 
696   = do { nm' <- tName nm
697        ; returnL $ UserTyVar nm' 
698        }
699 cvt_tv (TH.KindedTV nm ki) 
700   = do { nm' <- tName nm
701        ; returnL $ KindedTyVar nm' (cvtKind ki)
702        }
703
704 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
705 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
706
707 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
708 cvtPred (TH.ClassP cla tys)
709   = do { cla' <- if isVarName cla then tName cla else tconName cla
710        ; tys' <- mapM cvtType tys
711        ; returnL $ HsClassP cla' tys'
712        }
713 cvtPred (TH.EqualP ty1 ty2)
714   = do { ty1' <- cvtType ty1
715        ; ty2' <- cvtType ty2
716        ; returnL $ HsEqualP ty1' ty2'
717        }
718
719 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
720 cvtPredTy ty 
721   = do  { (head, tys') <- split_ty_app ty
722         ; case head of
723             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
724             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
725             _       -> failWith (ptext (sLit "Malformed predicate") <+> 
726                        text (TH.pprint ty)) }
727
728 cvtType :: TH.Type -> CvtM (LHsType RdrName)
729 cvtType ty 
730   = do { (head_ty, tys') <- split_ty_app ty
731        ; case head_ty of
732            TupleT n 
733              | length tys' == n         -- Saturated
734              -> if n==1 then return (head tys') -- Singleton tuples treated 
735                                                 -- like nothing (ie just parens)
736                         else returnL (HsTupleTy Boxed tys')
737              | n == 1    
738              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
739              | otherwise 
740              -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
741            ArrowT 
742              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
743              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
744            ListT  
745              | [x']    <- tys' -> returnL (HsListTy x')
746              | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
747            VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
748            ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
749
750            ForallT tvs cxt ty 
751              | null tys' 
752              -> do { tvs' <- cvtTvs tvs
753                    ; cxt' <- cvtContext cxt
754                    ; ty'  <- cvtType ty
755                    ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' 
756                    }
757
758            SigT ty ki
759              -> do { ty' <- cvtType ty
760                    ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
761                    }
762
763            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
764     }
765   where
766     mk_apps head_ty []       = returnL head_ty
767     mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
768                                   ; mk_apps (HsAppTy head_ty' ty) tys }
769
770 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
771 split_ty_app ty = go ty []
772   where
773     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
774     go f as           = return (f,as)
775
776 cvtKind :: TH.Kind -> Type.Kind
777 cvtKind StarK          = liftedTypeKind
778 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
779
780 -----------------------------------------------------------
781
782
783 -----------------------------------------------------------
784 -- some useful things
785
786 overloadedLit :: Lit -> Bool
787 -- True for literals that Haskell treats as overloaded
788 overloadedLit (IntegerL  _) = True
789 overloadedLit (RationalL _) = True
790 overloadedLit _             = False
791
792 void :: Type.Type
793 void = placeHolderType
794
795 --------------------------------------------------------------------
796 --      Turning Name back into RdrName
797 --------------------------------------------------------------------
798
799 -- variable names
800 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
801 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
802
803 vNameL n = wrapL (vName n)
804 vName n = cvtName OccName.varName n
805
806 -- Constructor function names; this is Haskell source, hence srcDataName
807 cNameL n = wrapL (cName n)
808 cName n = cvtName OccName.dataName n 
809
810 -- Type variable names
811 tName n = cvtName OccName.tvName n
812
813 -- Type Constructor names
814 tconNameL n = wrapL (tconName n)
815 tconName n = cvtName OccName.tcClsName n
816
817 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
818 cvtName ctxt_ns (TH.Name occ flavour)
819   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
820   | otherwise                   = force rdr_name >> return rdr_name
821   where
822     occ_str = TH.occString occ
823     rdr_name = thRdrName ctxt_ns occ_str flavour
824
825 okOcc :: OccName.NameSpace -> String -> Bool
826 okOcc _  []      = False
827 okOcc ns str@(c:_) 
828   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
829   | otherwise                 = startsConId c || startsConSym c || str == "[]"
830
831 -- Determine the name space of a name in a type
832 --
833 isVarName :: TH.Name -> Bool
834 isVarName (TH.Name occ _)
835   = case TH.occString occ of
836       ""    -> False
837       (c:_) -> startsVarId c || startsVarSym c
838
839 badOcc :: OccName.NameSpace -> String -> SDoc
840 badOcc ctxt_ns occ 
841   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
842         <+> ptext (sLit "name:") <+> quotes (text occ)
843
844 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
845 -- This turns a Name into a RdrName
846 -- The passed-in name space tells what the context is expecting;
847 --      use it unless the TH name knows what name-space it comes
848 --      from, in which case use the latter
849 --
850 -- ToDo: we may generate silly RdrNames, by passing a name space
851 --       that doesn't match the string, like VarName ":+", 
852 --       which will give confusing error messages later
853 -- 
854 -- The strict applications ensure that any buried exceptions get forced
855 thRdrName _       occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
856 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
857 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
858 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
859 thRdrName ctxt_ns occ TH.NameS
860   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
861   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
862
863 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
864 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
865
866 thRdrNameGuesses :: TH.Name -> [RdrName]
867 thRdrNameGuesses (TH.Name occ flavour)
868   -- This special case for NameG ensures that we don't generate duplicates in the output list
869   | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
870   | otherwise                         = [ thRdrName gns occ_str flavour
871                                         | gns <- guessed_nss]
872   where
873     -- guessed_ns are the name spaces guessed from looking at the TH name
874     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
875                 | otherwise                       = [OccName.varName, OccName.tvName]
876     occ_str = TH.occString occ
877
878 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
879 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
880 -- We must generate an Exact name, just as the parser does
881 isBuiltInOcc ctxt_ns occ
882   = case occ of
883         ":"              -> Just (Name.getName consDataCon)
884         "[]"             -> Just (Name.getName nilDataCon)
885         "()"             -> Just (tup_name 0)
886         '(' : ',' : rest -> go_tuple 2 rest
887         _                -> Nothing
888   where
889     go_tuple n ")"          = Just (tup_name n)
890     go_tuple n (',' : rest) = go_tuple (n+1) rest
891     go_tuple _ _            = Nothing
892
893     tup_name n 
894         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
895         | otherwise                        = Name.getName (tupleCon Boxed n)
896
897 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
898 mk_uniq_occ ns occ uniq 
899   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
900         -- The idea here is to make a name that 
901         -- a) the user could not possibly write, and
902         -- b) cannot clash with another NameU
903         -- Previously I generated an Exact RdrName with mkInternalName.
904         -- This works fine for local binders, but does not work at all for
905         -- top-level binders, which must have External Names, since they are
906         -- rapidly baked into data constructors and the like.  Baling out
907         -- and generating an unqualified RdrName here is the simple solution
908
909 -- The packing and unpacking is rather turgid :-(
910 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
911 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
912
913 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
914 mk_ghc_ns TH.DataName  = OccName.dataName
915 mk_ghc_ns TH.TcClsName = OccName.tcClsName
916 mk_ghc_ns TH.VarName   = OccName.varName
917
918 mk_mod :: TH.ModName -> ModuleName
919 mk_mod mod = mkModuleName (TH.modString mod)
920
921 mk_pkg :: TH.PkgName -> PackageId
922 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
923
924 mk_uniq :: Int# -> Unique
925 mk_uniq u = mkUniqueGrimily (I# u)
926 \end{code}
927