2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 This module converts Template Haskell syntax into HsSyn
9 module Convert( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) where
11 #include "HsVersions.h"
13 import Language.Haskell.TH as TH hiding (sigP)
14 import Language.Haskell.TH.Syntax as TH
17 import qualified Class (FunDep)
18 import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName )
19 import Name ( mkInternalName )
20 import Module ( Module, mkModule )
21 import RdrHsSyn ( mkClassDecl, mkTyData )
22 import qualified OccName
23 import SrcLoc ( unLoc, Located(..), SrcSpan )
25 import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon )
26 import BasicTypes( Boxity(..) )
27 import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
29 import Char ( isAscii, isAlphaNum, isAlpha )
30 import List ( partition )
31 import Unique ( Unique, mkUniqueGrimily )
32 import ErrUtils (Message)
33 import GLAEXTS ( Int(..), Int# )
34 import SrcLoc ( noSrcLoc )
35 import Bag ( emptyBag, consBag )
40 -------------------------------------------------------------------
41 convertToHsDecls :: SrcSpan -> [TH.Dec] -> [Either (LHsDecl RdrName) Message]
42 -- Use the loc everywhere, for lack of anything better
43 -- In particular, we want it on binding locations, so that variables bound in
44 -- the spliced-in declarations get a location that at least relates to the splice point
45 convertToHsDecls loc ds = map (cvt_top loc) ds
47 cvt_top :: SrcSpan -> TH.Dec -> Either (LHsDecl RdrName) Message
48 cvt_top loc d@(TH.ValD _ _ _) = Left $ L loc $ Hs.ValD (unLoc (cvtd loc d))
49 cvt_top loc d@(TH.FunD _ _) = Left $ L loc $ Hs.ValD (unLoc (cvtd loc d))
50 cvt_top loc (TH.SigD nm typ) = Left $ L loc $ Hs.SigD (Sig (L loc (vName nm)) (cvtType loc typ))
52 cvt_top loc (TySynD tc tvs rhs)
53 = Left $ L loc $ TyClD (TySynonym (L loc (tconName tc)) (cvt_tvs loc tvs) (cvtType loc rhs))
55 cvt_top loc (DataD ctxt tc tvs constrs derivs)
56 = Left $ L loc $ TyClD (mkTyData DataType
57 (L loc (cvt_context loc ctxt, L loc (tconName tc), cvt_tvs loc tvs))
58 Nothing (map (mk_con loc) constrs)
59 (mk_derivs loc derivs))
61 cvt_top loc (NewtypeD ctxt tc tvs constr derivs)
62 = Left $ L loc $ TyClD (mkTyData NewType
63 (L loc (cvt_context loc ctxt, L loc (tconName tc), cvt_tvs loc tvs))
64 Nothing [mk_con loc constr]
65 (mk_derivs loc derivs))
67 cvt_top loc (ClassD ctxt cl tvs fds decs)
68 = Left $ L loc $ TyClD $ mkClassDecl (cvt_context loc ctxt,
71 (map (L loc . cvt_fundep) fds)
75 (binds,sigs) = cvtBindsAndSigs loc decs
77 cvt_top loc (InstanceD tys ty decs)
78 = Left $ L loc $ InstD (InstDecl (L loc inst_ty) binds sigs)
80 (binds, sigs) = cvtBindsAndSigs loc decs
81 inst_ty = mkImplicitHsForAllTy (cvt_context loc tys) (L loc (HsPredTy (cvt_pred loc ty)))
83 cvt_top loc (ForeignD (ImportF callconv safety from nm typ))
85 Just (c_header, cis) ->
86 let i = CImport callconv' safety' c_header nilFS cis
87 in Left $ L loc $ ForD (ForeignImport (L loc (vName nm)) (cvtType loc typ) i False)
88 Nothing -> Right $ text (show from)
89 <+> ptext SLIT("is not a valid ccall impent")
90 where callconv' = case callconv of
92 StdCall -> StdCallConv
93 safety' = case safety of
95 Safe -> PlaySafe False
96 Threadsafe -> PlaySafe True
97 parsed = parse_ccall_impent (TH.nameBase nm) from
99 cvt_top loc (ForeignD (ExportF callconv as nm typ))
100 = let e = CExport (CExportStatic (mkFastString as) callconv')
101 in Left $ L loc $ ForD (ForeignExport (L loc (vName nm)) (cvtType loc typ) e False)
102 where callconv' = case callconv of
104 StdCall -> StdCallConv
106 mk_con loc con = L loc $ mk_nlcon con
108 -- Can't handle GADTs yet
109 mk_nlcon con = case con of
111 -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
112 (PrefixCon (map mk_arg strtys)) ResTyH98
114 -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
115 (RecCon (map mk_id_arg varstrtys)) ResTyH98
117 -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
118 (InfixCon (mk_arg st1) (mk_arg st2)) ResTyH98
119 ForallC tvs ctxt (ForallC tvs' ctxt' con')
120 -> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
121 ForallC tvs ctxt con' -> case mk_nlcon con' of
122 ConDecl l _ [] (L _ []) x ResTyH98 ->
123 ConDecl l Explicit (cvt_tvs loc tvs) (cvt_context loc ctxt) x ResTyH98
124 c -> panic "ForallC: Can't happen"
125 mk_arg (IsStrict, ty) = L loc $ HsBangTy HsStrict (cvtType loc ty)
126 mk_arg (NotStrict, ty) = cvtType loc ty
128 mk_id_arg (i, IsStrict, ty)
129 = (L loc (vName i), L loc $ HsBangTy HsStrict (cvtType loc ty))
130 mk_id_arg (i, NotStrict, ty)
131 = (L loc (vName i), cvtType loc ty)
133 mk_derivs loc [] = Nothing
134 mk_derivs loc cs = Just [L loc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs]
136 cvt_fundep :: FunDep -> Class.FunDep RdrName
137 cvt_fundep (FunDep xs ys) = (map tName xs, map tName ys)
139 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
140 parse_ccall_impent nm s
141 = case lex_ccall_impent s of
142 Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
143 Just ["wrapper"] -> Just (nilFS, CWrapper)
144 Just ("static":ts) -> parse_ccall_impent_static nm ts
145 Just ts -> parse_ccall_impent_static nm ts
148 parse_ccall_impent_static :: String
150 -> Maybe (FastString, CImportSpec)
151 parse_ccall_impent_static nm ts
152 = let ts' = case ts of
153 [ "&", cid] -> [ cid]
154 [fname, "&" ] -> [fname ]
155 [fname, "&", cid] -> [fname, cid]
158 [ cid] | is_cid cid -> Just (nilFS, mk_cid cid)
159 [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
160 [ ] -> Just (nilFS, mk_cid nm)
161 [fname ] -> Just (mkFastString fname, mk_cid nm)
163 where is_cid :: String -> Bool
164 is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
165 mk_cid :: String -> CImportSpec
166 mk_cid = CFunction . StaticTarget . mkFastString
168 lex_ccall_impent :: String -> Maybe [String]
169 lex_ccall_impent "" = Just []
170 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
171 lex_ccall_impent (' ':xs) = lex_ccall_impent xs
172 lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
173 lex_ccall_impent xs = case span is_valid xs of
175 (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
176 where is_valid :: Char -> Bool
177 is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
179 noContext loc = L loc []
182 -------------------------------------------------------------------
183 convertToHsExpr :: SrcSpan -> TH.Exp -> LHsExpr RdrName
184 convertToHsExpr loc e = cvtl loc e
188 cvt_l e = L loc (cvt e)
190 cvt (VarE s) = HsVar (vName s)
191 cvt (ConE s) = HsVar (cName s)
193 | overloadedLit l = HsOverLit (cvtOverLit l)
194 | otherwise = HsLit (cvtLit l)
196 cvt (AppE x y) = HsApp (cvt_l x) (cvt_l y)
197 cvt (LamE ps e) = HsLam (mkMatchGroup [mkSimpleMatch (map (cvtlp loc) ps) (cvtl loc e)])
198 cvt (TupE [e]) = cvt e
199 cvt (TupE es) = ExplicitTuple(map cvt_l es) Boxed
200 cvt (CondE x y z) = HsIf (cvt_l x) (cvt_l y) (cvt_l z)
201 cvt (LetE ds e) = HsLet (cvtdecs loc ds) (cvt_l e)
202 cvt (CaseE e ms) = HsCase (cvt_l e) (mkMatchGroup (map (cvtm loc) ms))
203 cvt (DoE ss) = cvtHsDo loc DoExpr ss
204 cvt (CompE ss) = cvtHsDo loc ListComp ss
205 cvt (ArithSeqE dd) = ArithSeq noPostTcExpr (cvtdd loc dd)
206 cvt (ListE xs) = ExplicitList void (map cvt_l xs)
207 cvt (InfixE (Just x) s (Just y))
208 = HsPar (L loc $ OpApp (cvt_l x) (cvt_l s) undefined (cvt_l y))
209 cvt (InfixE Nothing s (Just y)) = SectionR (cvt_l s) (cvt_l y)
210 cvt (InfixE (Just x) s Nothing ) = SectionL (cvt_l x) (cvt_l s)
211 cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
212 cvt (SigE e t) = ExprWithTySig (cvt_l e) (cvtType loc t)
213 cvt (RecConE c flds) = RecordCon (L loc (cName c)) noPostTcExpr
214 (map (\(x,y) -> (L loc (vName x), cvt_l y)) flds)
215 cvt (RecUpdE e flds) = RecordUpd (cvt_l e) (map (\(x,y) -> (L loc (vName x), cvt_l y)) flds)
216 placeHolderType placeHolderType
218 cvtHsDo loc do_or_lc stmts
219 = HsDo do_or_lc (init stmts') body void
221 stmts' = cvtstmts loc stmts
222 body = case last stmts' of
223 L _ (ExprStmt body _ _) -> body
225 cvtdecs :: SrcSpan -> [TH.Dec] -> HsLocalBinds RdrName
226 cvtdecs loc [] = EmptyLocalBinds
227 cvtdecs loc ds = HsValBinds (ValBindsIn binds sigs)
229 (binds, sigs) = cvtBindsAndSigs loc ds
231 cvtBindsAndSigs loc ds
232 = (cvtds loc non_sigs, map (cvtSig loc) sigs)
234 (sigs, non_sigs) = partition sigP ds
236 cvtSig loc (TH.SigD nm typ) = L loc (Hs.Sig (L loc (vName nm)) (cvtType loc typ))
238 cvtds :: SrcSpan -> [TH.Dec] -> LHsBinds RdrName
239 cvtds loc [] = emptyBag
240 cvtds loc (d:ds) = cvtd loc d `consBag` cvtds loc ds
242 cvtd :: SrcSpan -> TH.Dec -> LHsBind RdrName
243 -- Used only for declarations in a 'let/where' clause,
244 -- not for top level decls
245 cvtd loc (TH.ValD (TH.VarP s) body ds)
246 = L loc $ FunBind (L loc (vName s)) False
247 (mkMatchGroup [cvtclause loc (Clause [] body ds)])
249 cvtd loc (FunD nm cls)
250 = L loc $ FunBind (L loc (vName nm)) False
251 (mkMatchGroup (map (cvtclause loc) cls))
253 cvtd loc (TH.ValD p body ds)
254 = L loc $ PatBind (cvtlp loc p) (GRHSs (cvtguard loc body) (cvtdecs loc ds))
255 void placeHolderNames
257 cvtd loc d = cvtPanic "Illegal kind of declaration in where clause"
261 cvtclause :: SrcSpan -> TH.Clause -> Hs.LMatch RdrName
262 cvtclause loc (Clause ps body wheres)
263 = L loc $ Hs.Match (map (cvtlp loc) ps) Nothing (GRHSs (cvtguard loc body) (cvtdecs loc wheres))
267 cvtdd :: SrcSpan -> Range -> ArithSeqInfo RdrName
268 cvtdd loc (FromR x) = (From (cvtl loc x))
269 cvtdd loc (FromThenR x y) = (FromThen (cvtl loc x) (cvtl loc y))
270 cvtdd loc (FromToR x y) = (FromTo (cvtl loc x) (cvtl loc y))
271 cvtdd loc (FromThenToR x y z) = (FromThenTo (cvtl loc x) (cvtl loc y) (cvtl loc z))
274 cvtstmts :: SrcSpan -> [TH.Stmt] -> [Hs.LStmt RdrName]
276 cvtstmts loc (NoBindS e : ss) = L loc (mkExprStmt (cvtl loc e)) : cvtstmts loc ss
277 cvtstmts loc (TH.BindS p e : ss) = L loc (mkBindStmt (cvtlp loc p) (cvtl loc e)) : cvtstmts loc ss
278 cvtstmts loc (TH.LetS ds : ss) = L loc (LetStmt (cvtdecs loc ds)) : cvtstmts loc ss
279 cvtstmts loc (TH.ParS dss : ss) = L loc (ParStmt [(cvtstmts loc ds, undefined) | ds <- dss]) : cvtstmts loc ss
281 cvtm :: SrcSpan -> TH.Match -> Hs.LMatch RdrName
282 cvtm loc (TH.Match p body wheres)
283 = L loc (Hs.Match [cvtlp loc p] Nothing (GRHSs (cvtguard loc body) (cvtdecs loc wheres)))
285 cvtguard :: SrcSpan -> TH.Body -> [LGRHS RdrName]
286 cvtguard loc (GuardedB pairs) = map (cvtpair loc) pairs
287 cvtguard loc (NormalB e) = [L loc (GRHS [] (cvtl loc e))]
289 cvtpair :: SrcSpan -> (TH.Guard,TH.Exp) -> LGRHS RdrName
290 cvtpair loc (NormalG x,y) = L loc (GRHS [L loc $ mkBindStmt truePat (cvtl loc x)]
292 cvtpair loc (PatG x,y) = L loc (GRHS (cvtstmts loc x) (cvtl loc y))
294 cvtOverLit :: Lit -> HsOverLit RdrName
295 cvtOverLit (IntegerL i) = mkHsIntegral i
296 cvtOverLit (RationalL r) = mkHsFractional r
297 -- An Integer is like an an (overloaded) '3' in a Haskell source program
298 -- Similarly 3.5 for fractionals
300 cvtLit :: Lit -> HsLit
301 cvtLit (IntPrimL i) = HsIntPrim i
302 cvtLit (FloatPrimL f) = HsFloatPrim f
303 cvtLit (DoublePrimL f) = HsDoublePrim f
304 cvtLit (CharL c) = HsChar c
305 cvtLit (StringL s) = HsString (mkFastString s)
307 cvtlp :: SrcSpan -> TH.Pat -> Hs.LPat RdrName
308 cvtlp loc pat = L loc (cvtp loc pat)
310 cvtp :: SrcSpan -> TH.Pat -> Hs.Pat RdrName
312 | overloadedLit l = mkNPat (cvtOverLit l) Nothing -- Not right for negative
313 -- patterns; need to think
315 | otherwise = Hs.LitPat (cvtLit l)
316 cvtp loc (TH.VarP s) = Hs.VarPat(vName s)
317 cvtp loc (TupP [p]) = cvtp loc p
318 cvtp loc (TupP ps) = TuplePat (map (cvtlp loc) ps) Boxed
319 cvtp loc (ConP s ps) = ConPatIn (L loc (cName s)) (PrefixCon (map (cvtlp loc) ps))
320 cvtp loc (InfixP p1 s p2)
321 = ConPatIn (L loc (cName s)) (InfixCon (cvtlp loc p1) (cvtlp loc p2))
322 cvtp loc (TildeP p) = LazyPat (cvtlp loc p)
323 cvtp loc (TH.AsP s p) = AsPat (L loc (vName s)) (cvtlp loc p)
324 cvtp loc TH.WildP = WildPat void
325 cvtp loc (RecP c fs) = ConPatIn (L loc (cName c)) $ Hs.RecCon (map (\(s,p) -> (L loc (vName s),cvtlp loc p)) fs)
326 cvtp loc (ListP ps) = ListPat (map (cvtlp loc) ps) void
327 cvtp loc (SigP p t) = SigPatIn (cvtlp loc p) (cvtType loc t)
329 -----------------------------------------------------------
330 -- Types and type variables
332 cvt_tvs :: SrcSpan -> [TH.Name] -> [LHsTyVarBndr RdrName]
333 cvt_tvs loc tvs = map (L loc . UserTyVar . tName) tvs
335 cvt_context :: SrcSpan -> Cxt -> LHsContext RdrName
336 cvt_context loc tys = L loc (map (L loc . cvt_pred loc) tys)
338 cvt_pred :: SrcSpan -> TH.Type -> HsPred RdrName
340 = case split_ty_app ty of
341 (ConT tc, tys) -> HsClassP (tconName tc) (map (cvtType loc) tys)
342 (VarT tv, tys) -> HsClassP (tName tv) (map (cvtType loc) tys)
343 other -> cvtPanic "Malformed predicate" (text (TH.pprint ty))
345 convertToHsType = cvtType
347 cvtType :: SrcSpan -> TH.Type -> LHsType RdrName
348 cvtType loc ty = trans (root ty [])
349 where root (AppT a b) zs = root a (cvtType loc b : zs)
352 trans (TupleT n,args)
353 | length args == n = L loc (HsTupleTy Boxed args)
354 | n == 0 = foldl nlHsAppTy (nlHsTyVar (getRdrName unitTyCon)) args
355 | otherwise = foldl nlHsAppTy (nlHsTyVar (getRdrName (tupleTyCon Boxed n))) args
356 trans (ArrowT, [x,y]) = nlHsFunTy x y
357 trans (ListT, [x]) = L loc (HsListTy x)
359 trans (VarT nm, args) = foldl nlHsAppTy (nlHsTyVar (tName nm)) args
360 trans (ConT tc, args) = foldl nlHsAppTy (nlHsTyVar (tconName tc)) args
362 trans (ForallT tvs cxt ty, []) = L loc $ mkExplicitHsForAllTy
363 (cvt_tvs loc tvs) (cvt_context loc cxt) (cvtType loc ty)
365 split_ty_app :: TH.Type -> (TH.Type, [TH.Type])
366 split_ty_app ty = go ty []
368 go (AppT f a) as = go f (a:as)
371 -----------------------------------------------------------
373 sigP (TH.SigD _ _) = True
377 -----------------------------------------------------------
378 cvtPanic :: String -> SDoc -> b
379 cvtPanic herald thing
380 = pprPanic herald (thing $$ ptext SLIT("When splicing generated code into the program"))
382 -----------------------------------------------------------
383 -- some useful things
385 truePat = nlConPat (getRdrName trueDataCon) []
387 overloadedLit :: Lit -> Bool
388 -- True for literals that Haskell treats as overloaded
389 overloadedLit (IntegerL l) = True
390 overloadedLit (RationalL l) = True
391 overloadedLit l = False
394 void = placeHolderType
396 --------------------------------------------------------------------
397 -- Turning Name back into RdrName
398 --------------------------------------------------------------------
401 vName :: TH.Name -> RdrName
402 vName = thRdrName OccName.varName
404 -- Constructor function names; this is Haskell source, hence srcDataName
405 cName :: TH.Name -> RdrName
406 cName = thRdrName OccName.srcDataName
408 -- Type variable names
409 tName :: TH.Name -> RdrName
410 tName = thRdrName OccName.tvName
412 -- Type Constructor names
413 tconName = thRdrName OccName.tcName
415 thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
416 -- This turns a Name into a RdrName
417 -- The passed-in name space tells what the context is expecting;
418 -- use it unless the TH name knows what name-space it comes
419 -- from, in which case use the latter
420 thRdrName ctxt_ns (TH.Name occ (TH.NameG th_ns mod)) = mkOrig (mk_mod mod) (mk_occ (mk_ghc_ns th_ns) occ)
421 thRdrName ctxt_ns (TH.Name occ (TH.NameL uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ctxt_ns occ) noSrcLoc)
422 thRdrName ctxt_ns (TH.Name occ (TH.NameQ mod)) = mkRdrQual (mk_mod mod) (mk_occ ctxt_ns occ)
423 thRdrName ctxt_ns (TH.Name occ TH.NameS) = mkRdrUnqual (mk_occ ctxt_ns occ)
424 thRdrName ctxt_ns (TH.Name occ (TH.NameU uniq)) = mkRdrUnqual (mk_uniq_occ ctxt_ns occ uniq)
426 mk_uniq_occ :: OccName.NameSpace -> TH.OccName -> Int# -> OccName.OccName
427 mk_uniq_occ ns occ uniq
428 = OccName.mkOccName ns (TH.occString occ ++ '[' : shows (mk_uniq uniq) "]")
429 -- The idea here is to make a name that
430 -- a) the user could not possibly write, and
431 -- b) cannot clash with another NameU
432 -- Previously I generated an Exact RdrName with mkInternalName.
433 -- This works fine for local binders, but does not work at all for
434 -- top-level binders, which must have External Names, since they are
435 -- rapidly baked into data constructors and the like. Baling out
436 -- and generating an unqualified RdrName here is the simple solution
438 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
439 mk_ghc_ns DataName = OccName.dataName
440 mk_ghc_ns TH.TcClsName = OccName.tcClsName
441 mk_ghc_ns TH.VarName = OccName.varName
443 -- The packing and unpacking is rather turgid :-(
444 mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName
445 mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
447 mk_mod :: TH.ModName -> Module
448 mk_mod mod = mkModule (TH.modString mod)
450 mk_uniq :: Int# -> Unique
451 mk_uniq u = mkUniqueGrimily (I# u)