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