give a more useful message when the static flags have not been initialised (#1938)
[ghc-hetmet.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 -w #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 -- for details
15
16 module Convert( convertToHsExpr, convertToHsDecls, 
17                 convertToHsType, thRdrName ) where
18
19 #include "HsVersions.h"
20
21 import HsSyn as Hs
22 import qualified Class
23 import RdrName
24 import qualified Name
25 import Module
26 import RdrHsSyn
27 import qualified OccName
28 import PackageConfig
29 import OccName
30 import SrcLoc
31 import Type
32 import TysWiredIn
33 import BasicTypes
34 import ForeignCall
35 import Char
36 import List
37 import Unique
38 import ErrUtils
39 import Bag
40 import FastString
41 import Outputable
42
43 import Language.Haskell.TH as TH hiding (sigP)
44 import Language.Haskell.TH.Syntax as TH
45
46 import GHC.Exts
47
48 -------------------------------------------------------------------
49 --              The external interface
50
51 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]
52 convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds)
53
54 convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
55 convertToHsExpr loc e 
56   = case initCvt loc (cvtl e) of
57         Left msg  -> Left (msg $$ (ptext SLIT("When converting TH expression")
58                                     <+> text (show e)))
59         Right res -> Right res
60
61 convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
62 convertToHsType loc t = initCvt loc (cvtType t)
63
64
65 -------------------------------------------------------------------
66 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
67         -- Push down the source location;
68         -- Can fail, with a single error message
69
70 -- NB: If the conversion succeeds with (Right x), there should 
71 --     be no exception values hiding in x
72 -- Reason: so a (head []) in TH code doesn't subsequently
73 --         make GHC crash when it tries to walk the generated tree
74
75 -- Use the loc everywhere, for lack of anything better
76 -- In particular, we want it on binding locations, so that variables bound in
77 -- the spliced-in declarations get a location that at least relates to the splice point
78
79 instance Monad CvtM where
80   return x       = CvtM $ \loc -> Right x
81   (CvtM m) >>= k = CvtM $ \loc -> case m loc of
82                                     Left err -> Left err
83                                     Right v  -> unCvtM (k v) loc
84
85 initCvt :: SrcSpan -> CvtM a -> Either Message a
86 initCvt loc (CvtM m) = m loc
87
88 force :: a -> CvtM a
89 force a = a `seq` return a
90
91 failWith :: Message -> CvtM a
92 failWith m = CvtM (\loc -> Left full_msg)
93    where
94      full_msg = m $$ ptext SLIT("When splicing generated code into the program")
95
96 returnL :: a -> CvtM (Located a)
97 returnL x = CvtM (\loc -> Right (L loc x))
98
99 wrapL :: CvtM a -> CvtM (Located a)
100 wrapL (CvtM m) = CvtM (\loc -> case m loc of
101                           Left err -> Left err
102                           Right v  -> Right (L loc v))
103
104 -------------------------------------------------------------------
105 cvtTop :: TH.Dec -> CvtM (LHsDecl RdrName)
106 cvtTop d@(TH.ValD _ _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
107 cvtTop d@(TH.FunD _ _)   = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
108 cvtTop (TH.SigD nm typ)  = do  { nm' <- vNameL nm
109                                 ; ty' <- cvtType typ
110                                 ; returnL $ Hs.SigD (TypeSig nm' ty') }
111
112 cvtTop (TySynD tc tvs rhs)
113   = do  { tc' <- tconNameL tc
114         ; tvs' <- cvtTvs tvs
115         ; rhs' <- cvtType rhs
116         ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
117
118 cvtTop (DataD ctxt tc tvs constrs derivs)
119   = do  { stuff <- cvt_tycl_hdr ctxt tc tvs
120         ; cons' <- mapM cvtConstr constrs
121         ; derivs' <- cvtDerivs derivs
122         ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') }
123
124
125 cvtTop (NewtypeD ctxt tc tvs constr derivs)
126   = do  { stuff <- cvt_tycl_hdr ctxt tc tvs
127         ; con' <- cvtConstr constr
128         ; derivs' <- cvtDerivs derivs
129         ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') }
130
131 cvtTop (ClassD ctxt cl tvs fds decs)
132   = do  { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
133         ; fds'  <- mapM cvt_fundep fds
134         ; (binds', sigs') <- cvtBindsAndSigs decs
135         ; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] []
136                                                     -- no ATs or docs in TH ^^ ^^
137         }
138
139 cvtTop (InstanceD tys ty decs)
140   = do  { (binds', sigs') <- cvtBindsAndSigs decs
141         ; ctxt' <- cvtContext tys
142         ; L loc pred' <- cvtPred ty
143         ; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
144         ; returnL $ InstD (InstDecl inst_ty' binds' sigs' [])
145                                                        -- ^^no ATs in TH
146         }
147
148 cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
149
150 cvt_tycl_hdr cxt tc tvs
151   = do  { cxt' <- cvtContext cxt
152         ; tc'  <- tconNameL tc
153         ; tvs' <- cvtTvs tvs
154         ; return (cxt', tc', tvs', Nothing) }
155
156 ---------------------------------------------------
157 --      Data types
158 -- Can't handle GADTs yet
159 ---------------------------------------------------
160
161 cvtConstr (NormalC c strtys)
162   = do  { c'   <- cNameL c 
163         ; cxt' <- returnL []
164         ; tys' <- mapM cvt_arg strtys
165         ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing }
166
167 cvtConstr (RecC c varstrtys)
168   = do  { c'    <- cNameL c 
169         ; cxt'  <- returnL []
170         ; args' <- mapM cvt_id_arg varstrtys
171         ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing }
172
173 cvtConstr (InfixC st1 c st2)
174   = do  { c' <- cNameL c 
175         ; cxt' <- returnL []
176         ; st1' <- cvt_arg st1
177         ; st2' <- cvt_arg st2
178         ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing }
179
180 cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
181   = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
182
183 cvtConstr (ForallC tvs ctxt con)
184   = do  { L _ con' <- cvtConstr con
185         ; tvs'  <- cvtTvs tvs
186         ; ctxt' <- cvtContext ctxt
187         ; case con' of
188             ConDecl l _ [] (L _ []) x ResTyH98 _
189               -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing
190             c -> panic "ForallC: Can't happen" }
191
192 cvt_arg (IsStrict, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
193 cvt_arg (NotStrict, ty) = cvtType ty
194
195 cvt_id_arg (i, str, ty) 
196   = do  { i' <- vNameL i
197         ; ty' <- cvt_arg (str,ty)
198         ; return (ConDeclField { cd_fld_name = i', cd_fld_type =  ty', cd_fld_doc = Nothing}) }
199
200 cvtDerivs [] = return Nothing
201 cvtDerivs cs = do { cs' <- mapM cvt_one cs
202                   ; return (Just cs') }
203         where
204           cvt_one c = do { c' <- tconName c
205                          ; returnL $ HsPredTy $ HsClassP c' [] }
206
207 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
208 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
209
210 noExistentials = []
211
212 ------------------------------------------
213 --      Foreign declarations
214 ------------------------------------------
215
216 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
217 cvtForD (ImportF callconv safety from nm ty)
218   | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from
219   = do  { nm' <- vNameL nm
220         ; ty' <- cvtType ty
221         ; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis
222         ; return $ ForeignImport nm' ty' i }
223
224   | otherwise
225   = failWith $ text (show from)<+> ptext SLIT("is not a valid ccall impent")
226   where 
227     safety' = case safety of
228                      Unsafe     -> PlayRisky
229                      Safe       -> PlaySafe False
230                      Threadsafe -> PlaySafe True
231
232 cvtForD (ExportF callconv as nm ty)
233   = do  { nm' <- vNameL nm
234         ; ty' <- cvtType ty
235         ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
236         ; return $ ForeignExport nm' ty' e }
237
238 cvt_conv TH.CCall   = CCallConv
239 cvt_conv TH.StdCall = StdCallConv
240
241 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
242 parse_ccall_impent nm s
243  = case lex_ccall_impent s of
244        Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
245        Just ["wrapper"] -> Just (nilFS, CWrapper)
246        Just ("static":ts) -> parse_ccall_impent_static nm ts
247        Just ts -> parse_ccall_impent_static nm ts
248        Nothing -> Nothing
249
250 parse_ccall_impent_static :: String
251                           -> [String]
252                           -> Maybe (FastString, CImportSpec)
253 parse_ccall_impent_static nm ts
254  = let ts' = case ts of
255                  [       "&", cid] -> [       cid]
256                  [fname, "&"     ] -> [fname     ]
257                  [fname, "&", cid] -> [fname, cid]
258                  _                 -> ts
259    in case ts' of
260           [       cid] | is_cid cid -> Just (nilFS,              mk_cid cid)
261           [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
262           [          ]              -> Just (nilFS,              mk_cid nm)
263           [fname     ]              -> Just (mkFastString fname, mk_cid nm)
264           _                         -> Nothing
265     where is_cid :: String -> Bool
266           is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
267           mk_cid :: String -> CImportSpec
268           mk_cid  = CFunction . StaticTarget . mkFastString
269
270 lex_ccall_impent :: String -> Maybe [String]
271 lex_ccall_impent "" = Just []
272 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
273 lex_ccall_impent (' ':xs) = lex_ccall_impent xs
274 lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
275 lex_ccall_impent xs = case span is_valid xs of
276                           ("", _) -> Nothing
277                           (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
278     where is_valid :: Char -> Bool
279           is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
280
281
282 ---------------------------------------------------
283 --              Declarations
284 ---------------------------------------------------
285
286 cvtDecs :: [TH.Dec] -> CvtM (HsLocalBinds RdrName)
287 cvtDecs [] = return EmptyLocalBinds
288 cvtDecs ds = do { (binds,sigs) <- cvtBindsAndSigs ds
289                 ; return (HsValBinds (ValBindsIn binds sigs)) }
290
291 cvtBindsAndSigs ds 
292   = do { binds' <- mapM cvtBind binds; sigs' <- mapM cvtSig sigs
293        ; return (listToBag binds', sigs') }
294   where 
295     (sigs, binds) = partition is_sig ds
296
297     is_sig (TH.SigD _ _) = True
298     is_sig other         = False
299
300 cvtSig (TH.SigD nm ty)
301   = do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') }
302
303 cvtBind :: TH.Dec -> CvtM (LHsBind RdrName)
304 -- Used only for declarations in a 'let/where' clause,
305 -- not for top level decls
306 cvtBind (TH.ValD (TH.VarP s) body ds) 
307   = do  { s' <- vNameL s
308         ; cl' <- cvtClause (Clause [] body ds)
309         ; returnL $ mkFunBind s' [cl'] }
310
311 cvtBind (TH.FunD nm cls)
312   = do  { nm' <- vNameL nm
313         ; cls' <- mapM cvtClause cls
314         ; returnL $ mkFunBind nm' cls' }
315
316 cvtBind (TH.ValD p body ds)
317   = do  { p' <- cvtPat p
318         ; g' <- cvtGuard body
319         ; ds' <- cvtDecs ds
320         ; returnL $ PatBind { pat_lhs = p', pat_rhs = GRHSs g' ds', 
321                               pat_rhs_ty = void, bind_fvs = placeHolderNames } }
322
323 cvtBind d 
324   = failWith (sep [ptext SLIT("Illegal kind of declaration in where clause"),
325                    nest 2 (text (TH.pprint d))])
326
327 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
328 cvtClause (Clause ps body wheres)
329   = do  { ps' <- cvtPats ps
330         ; g'  <- cvtGuard body
331         ; ds' <- cvtDecs wheres
332         ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
333
334
335 -------------------------------------------------------------------
336 --              Expressions
337 -------------------------------------------------------------------
338
339 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
340 cvtl e = wrapL (cvt e)
341   where
342     cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
343     cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
344     cvt (LitE l) 
345       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
346       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
347
348     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
349     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e 
350                             ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
351     cvt (TupE [e])     = cvt e
352     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed }
353     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
354                             ; return $ HsIf x' y' z' }
355     cvt (LetE ds e)    = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
356     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
357                             ; return $ HsCase e' (mkMatchGroup ms') }
358     cvt (DoE ss)       = cvtHsDo DoExpr ss
359     cvt (CompE ss)     = cvtHsDo ListComp ss
360     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
361     cvt (ListE xs)     = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
362     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
363                                           ; e' <- returnL $ OpApp x' s' undefined y'
364                                           ; return $ HsPar e' }
365     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
366                                           ; return $ SectionR s' y' }
367     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
368                                           ; return $ SectionL x' s' }
369     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
370
371     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
372                               ; return $ ExprWithTySig e' t' }
373     cvt (RecConE c flds) = do { c' <- cNameL c
374                               ; flds' <- mapM cvtFld flds
375                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
376     cvt (RecUpdE e flds) = do { e' <- cvtl e
377                               ; flds' <- mapM cvtFld flds
378                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
379
380 cvtFld (v,e) 
381   = do  { v' <- vNameL v; e' <- cvtl e
382         ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
383
384 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
385 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
386 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
387 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
388 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
389
390 -------------------------------------
391 --      Do notation and statements
392 -------------------------------------
393
394 cvtHsDo do_or_lc stmts
395   = do  { stmts' <- cvtStmts stmts
396         ; let body = case last stmts' of
397                         L _ (ExprStmt body _ _) -> body
398         ; return $ HsDo do_or_lc (init stmts') body void }
399
400 cvtStmts = mapM cvtStmt 
401
402 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
403 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
404 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
405 cvtStmt (TH.LetS ds)   = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' }
406 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
407                        where
408                          cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
409
410 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
411 cvtMatch (TH.Match p body decs)
412   = do  { p' <- cvtPat p
413         ; g' <- cvtGuard body
414         ; decs' <- cvtDecs decs
415         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
416
417 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
418 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
419 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
420
421 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
422 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
423                               ; g' <- returnL $ mkBindStmt truePat ge'
424                               ; returnL $ GRHS [g'] rhs' }
425 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
426                               ; returnL $ GRHS gs' rhs' }
427
428 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
429 cvtOverLit (IntegerL i)  = do { force i; return $ mkHsIntegral i placeHolderType}
430 cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r placeHolderType}
431 cvtOverLit (StringL s)   = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' placeHolderType }
432 -- An Integer is like an an (overloaded) '3' in a Haskell source program
433 -- Similarly 3.5 for fractionals
434
435 cvtLit :: Lit -> CvtM HsLit
436 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
437 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
438 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
439 cvtLit (CharL c)       = do { force c; return $ HsChar c }
440 cvtLit (StringL s)     = do { let { s' = mkFastString s }; force s'; return $ HsString s' }
441
442 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
443 cvtPats pats = mapM cvtPat pats
444
445 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
446 cvtPat pat = wrapL (cvtp pat)
447
448 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
449 cvtp (TH.LitP l)
450   | overloadedLit l   = do { l' <- cvtOverLit l
451                            ; return (mkNPat l' Nothing) }
452                                   -- Not right for negative patterns; 
453                                   -- need to think about that!
454   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
455 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
456 cvtp (TupP [p])       = cvtp p
457 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
458 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
459 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
460                            ; return $ ConPatIn s' (InfixCon p1' p2') }
461 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
462 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
463 cvtp TH.WildP         = return $ WildPat void
464 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs 
465                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
466 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
467 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
468
469 cvtPatFld (s,p)
470   = do  { s' <- vNameL s; p' <- cvtPat p
471         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
472
473 -----------------------------------------------------------
474 --      Types and type variables
475
476 cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName]
477 cvtTvs tvs = mapM cvt_tv tvs
478
479 cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' }
480
481 cvtContext :: Cxt -> CvtM (LHsContext RdrName)
482 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
483
484 cvtPred :: TH.Type -> CvtM (LHsPred RdrName)
485 cvtPred ty 
486   = do  { (head, tys') <- split_ty_app ty
487         ; case head of
488             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
489             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
490             other   -> failWith (ptext SLIT("Malformed predicate") <+> text (TH.pprint ty)) }
491
492 cvtType :: TH.Type -> CvtM (LHsType RdrName)
493 cvtType ty = do { (head, tys') <- split_ty_app ty
494                 ; case head of
495                     TupleT n | length tys' == n -> returnL (HsTupleTy Boxed tys')
496                              | n == 0    -> mk_apps (HsTyVar (getRdrName unitTyCon)) tys'
497                              | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
498                     ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y')
499                     ListT  | [x']    <- tys' -> returnL (HsListTy x')
500                     VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
501                     ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
502
503                     ForallT tvs cxt ty | null tys' -> do { tvs' <- cvtTvs tvs
504                                                          ; cxt' <- cvtContext cxt
505                                                          ; ty'  <- cvtType ty
506                                                          ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' }
507                     otherwise -> failWith (ptext SLIT("Malformed type") <+> text (show ty))
508              }
509   where
510     mk_apps head []       = returnL head
511     mk_apps head (ty:tys) = do { head' <- returnL head; mk_apps (HsAppTy head' ty) tys }
512
513 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
514 split_ty_app ty = go ty []
515   where
516     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
517     go f as           = return (f,as)
518
519 -----------------------------------------------------------
520
521
522 -----------------------------------------------------------
523 -- some useful things
524
525 truePat  = nlConPat (getRdrName trueDataCon)  []
526
527 overloadedLit :: Lit -> Bool
528 -- True for literals that Haskell treats as overloaded
529 overloadedLit (IntegerL  l) = True
530 overloadedLit (RationalL l) = True
531 overloadedLit l             = False
532
533 void :: Type.Type
534 void = placeHolderType
535
536 --------------------------------------------------------------------
537 --      Turning Name back into RdrName
538 --------------------------------------------------------------------
539
540 -- variable names
541 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
542 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
543
544 vNameL n = wrapL (vName n)
545 vName n = cvtName OccName.varName n
546
547 -- Constructor function names; this is Haskell source, hence srcDataName
548 cNameL n = wrapL (cName n)
549 cName n = cvtName OccName.dataName n 
550
551 -- Type variable names
552 tName n = cvtName OccName.tvName n
553
554 -- Type Constructor names
555 tconNameL n = wrapL (tconName n)
556 tconName n = cvtName OccName.tcClsName n
557
558 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
559 cvtName ctxt_ns (TH.Name occ flavour)
560   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
561   | otherwise                   = force (thRdrName ctxt_ns occ_str flavour)
562   where
563     occ_str = TH.occString occ
564
565 okOcc :: OccName.NameSpace -> String -> Bool
566 okOcc _  []      = False
567 okOcc ns str@(c:_) 
568   | OccName.isVarName ns = startsVarId c || startsVarSym c
569   | otherwise            = startsConId c || startsConSym c || str == "[]"
570
571 badOcc :: OccName.NameSpace -> String -> SDoc
572 badOcc ctxt_ns occ 
573   = ptext SLIT("Illegal") <+> pprNameSpace ctxt_ns
574         <+> ptext SLIT("name:") <+> quotes (text occ)
575
576 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
577 -- This turns a Name into a RdrName
578 -- The passed-in name space tells what the context is expecting;
579 --      use it unless the TH name knows what name-space it comes
580 --      from, in which case use the latter
581 --
582 -- ToDo: we may generate silly RdrNames, by passing a name space
583 --       that doesn't match the string, like VarName ":+", 
584 --       which will give confusing error messages later
585 -- 
586 -- The strict applications ensure that any buried exceptions get forced
587 thRdrName ctxt_ns occ (TH.NameG th_ns pkg mod) = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
588 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
589 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
590 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
591 thRdrName ctxt_ns occ TH.NameS
592   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
593   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
594
595 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
596 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
597 -- We must generate an Exact name, just as the parser does
598 isBuiltInOcc ctxt_ns occ
599   = case occ of
600         ":"              -> Just (Name.getName consDataCon)
601         "[]"             -> Just (Name.getName nilDataCon)
602         "()"             -> Just (tup_name 0)
603         '(' : ',' : rest -> go_tuple 2 rest
604         other            -> Nothing
605   where
606     go_tuple n ")"          = Just (tup_name n)
607     go_tuple n (',' : rest) = go_tuple (n+1) rest
608     go_tuple n other        = Nothing
609
610     tup_name n 
611         | OccName.isTcClsName ctxt_ns = Name.getName (tupleTyCon Boxed n)
612         | otherwise                   = Name.getName (tupleCon Boxed n)
613
614 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
615 mk_uniq_occ ns occ uniq 
616   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
617         -- The idea here is to make a name that 
618         -- a) the user could not possibly write, and
619         -- b) cannot clash with another NameU
620         -- Previously I generated an Exact RdrName with mkInternalName.
621         -- This works fine for local binders, but does not work at all for
622         -- top-level binders, which must have External Names, since they are
623         -- rapidly baked into data constructors and the like.  Baling out
624         -- and generating an unqualified RdrName here is the simple solution
625
626 -- The packing and unpacking is rather turgid :-(
627 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
628 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
629
630 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
631 mk_ghc_ns TH.DataName  = OccName.dataName
632 mk_ghc_ns TH.TcClsName = OccName.tcClsName
633 mk_ghc_ns TH.VarName   = OccName.varName
634
635 mk_mod :: TH.ModName -> ModuleName
636 mk_mod mod = mkModuleName (TH.modString mod)
637
638 mk_pkg :: TH.ModName -> PackageId
639 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
640
641 mk_uniq :: Int# -> Unique
642 mk_uniq u = mkUniqueGrimily (I# u)
643 \end{code}
644