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(..), RecFlag(Recursive) )
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 mk_nlcon con = case con of
110 -> ConDecl (L loc (cName c)) noExistentials (noContext loc)
111 (PrefixCon (map mk_arg strtys))
113 -> ConDecl (L loc (cName c)) noExistentials (noContext loc)
114 (RecCon (map mk_id_arg varstrtys))
116 -> ConDecl (L loc (cName c)) noExistentials (noContext loc)
117 (InfixCon (mk_arg st1) (mk_arg st2))
118 ForallC tvs ctxt (ForallC tvs' ctxt' con')
119 -> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
120 ForallC tvs ctxt con' -> case mk_nlcon con' of
121 ConDecl l [] (L _ []) x ->
122 ConDecl l (cvt_tvs loc tvs) (cvt_context loc ctxt) x
123 c -> panic "ForallC: Can't happen"
124 mk_arg (IsStrict, ty) = L loc $ HsBangTy HsStrict (cvtType loc ty)
125 mk_arg (NotStrict, ty) = cvtType loc ty
127 mk_id_arg (i, IsStrict, ty)
128 = (L loc (vName i), L loc $ HsBangTy HsStrict (cvtType loc ty))
129 mk_id_arg (i, NotStrict, ty)
130 = (L loc (vName i), cvtType loc ty)
132 mk_derivs loc [] = Nothing
133 mk_derivs loc cs = Just [L loc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs]
135 cvt_fundep :: FunDep -> Class.FunDep RdrName
136 cvt_fundep (FunDep xs ys) = (map tName xs, map tName ys)
138 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
139 parse_ccall_impent nm s
140 = case lex_ccall_impent s of
141 Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
142 Just ["wrapper"] -> Just (nilFS, CWrapper)
143 Just ("static":ts) -> parse_ccall_impent_static nm ts
144 Just ts -> parse_ccall_impent_static nm ts
147 parse_ccall_impent_static :: String
149 -> Maybe (FastString, CImportSpec)
150 parse_ccall_impent_static nm ts
151 = let ts' = case ts of
152 [ "&", cid] -> [ cid]
153 [fname, "&" ] -> [fname ]
154 [fname, "&", cid] -> [fname, cid]
157 [ cid] | is_cid cid -> Just (nilFS, mk_cid cid)
158 [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
159 [ ] -> Just (nilFS, mk_cid nm)
160 [fname ] -> Just (mkFastString fname, mk_cid nm)
162 where is_cid :: String -> Bool
163 is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
164 mk_cid :: String -> CImportSpec
165 mk_cid = CFunction . StaticTarget . mkFastString
167 lex_ccall_impent :: String -> Maybe [String]
168 lex_ccall_impent "" = Just []
169 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
170 lex_ccall_impent (' ':xs) = lex_ccall_impent xs
171 lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
172 lex_ccall_impent xs = case span is_valid xs of
174 (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
175 where is_valid :: Char -> Bool
176 is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
178 noContext loc = L loc []
181 -------------------------------------------------------------------
182 convertToHsExpr :: SrcSpan -> TH.Exp -> LHsExpr RdrName
183 convertToHsExpr loc e = cvtl loc e
187 cvt_l e = L loc (cvt e)
189 cvt (VarE s) = HsVar (vName s)
190 cvt (ConE s) = HsVar (cName s)
192 | overloadedLit l = HsOverLit (cvtOverLit l)
193 | otherwise = HsLit (cvtLit l)
195 cvt (AppE x y) = HsApp (cvt_l x) (cvt_l y)
196 cvt (LamE ps e) = HsLam (mkMatchGroup [mkSimpleMatch (map (cvtlp loc) ps) (cvtl loc e)])
197 cvt (TupE [e]) = cvt e
198 cvt (TupE es) = ExplicitTuple(map cvt_l es) Boxed
199 cvt (CondE x y z) = HsIf (cvt_l x) (cvt_l y) (cvt_l z)
200 cvt (LetE ds e) = HsLet (cvtdecs loc ds) (cvt_l e)
201 cvt (CaseE e ms) = HsCase (cvt_l e) (mkMatchGroup (map (cvtm loc) ms))
202 cvt (DoE ss) = cvtHsDo loc DoExpr ss
203 cvt (CompE ss) = cvtHsDo loc ListComp ss
204 cvt (ArithSeqE dd) = ArithSeq noPostTcExpr (cvtdd loc dd)
205 cvt (ListE xs) = ExplicitList void (map cvt_l xs)
206 cvt (InfixE (Just x) s (Just y))
207 = HsPar (L loc $ OpApp (cvt_l x) (cvt_l s) undefined (cvt_l y))
208 cvt (InfixE Nothing s (Just y)) = SectionR (cvt_l s) (cvt_l y)
209 cvt (InfixE (Just x) s Nothing ) = SectionL (cvt_l x) (cvt_l s)
210 cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
211 cvt (SigE e t) = ExprWithTySig (cvt_l e) (cvtType loc t)
212 cvt (RecConE c flds) = RecordCon (L loc (cName c)) noPostTcExpr
213 (map (\(x,y) -> (L loc (vName x), cvt_l y)) flds)
214 cvt (RecUpdE e flds) = RecordUpd (cvt_l e) (map (\(x,y) -> (L loc (vName x), cvt_l y)) flds)
215 placeHolderType placeHolderType
217 cvtHsDo loc do_or_lc stmts
218 = HsDo do_or_lc (init stmts') body void
220 stmts' = cvtstmts loc stmts
221 body = case last stmts' of
222 L _ (ExprStmt body _ _) -> body
224 cvtdecs :: SrcSpan -> [TH.Dec] -> [HsBindGroup RdrName]
226 cvtdecs loc ds = [HsBindGroup binds sigs Recursive]
228 (binds, sigs) = cvtBindsAndSigs loc ds
230 cvtBindsAndSigs loc ds
231 = (cvtds loc non_sigs, map (cvtSig loc) sigs)
233 (sigs, non_sigs) = partition sigP ds
235 cvtSig loc (TH.SigD nm typ) = L loc (Hs.Sig (L loc (vName nm)) (cvtType loc typ))
237 cvtds :: SrcSpan -> [TH.Dec] -> LHsBinds RdrName
238 cvtds loc [] = emptyBag
239 cvtds loc (d:ds) = cvtd loc d `consBag` cvtds loc ds
241 cvtd :: SrcSpan -> TH.Dec -> LHsBind RdrName
242 -- Used only for declarations in a 'let/where' clause,
243 -- not for top level decls
244 cvtd loc (TH.ValD (TH.VarP s) body ds)
245 = L loc $ FunBind (L loc (vName s)) False (mkMatchGroup [cvtclause loc (Clause [] body ds)])
246 cvtd loc (FunD nm cls)
247 = L loc $ FunBind (L loc (vName nm)) False (mkMatchGroup (map (cvtclause loc) cls))
248 cvtd loc (TH.ValD p body ds)
249 = L loc $ PatBind (cvtlp loc p) (GRHSs (cvtguard loc body) (cvtdecs loc ds)) void
251 cvtd loc d = cvtPanic "Illegal kind of declaration in where clause"
255 cvtclause :: SrcSpan -> TH.Clause -> Hs.LMatch RdrName
256 cvtclause loc (Clause ps body wheres)
257 = L loc $ Hs.Match (map (cvtlp loc) ps) Nothing (GRHSs (cvtguard loc body) (cvtdecs loc wheres))
261 cvtdd :: SrcSpan -> Range -> ArithSeqInfo RdrName
262 cvtdd loc (FromR x) = (From (cvtl loc x))
263 cvtdd loc (FromThenR x y) = (FromThen (cvtl loc x) (cvtl loc y))
264 cvtdd loc (FromToR x y) = (FromTo (cvtl loc x) (cvtl loc y))
265 cvtdd loc (FromThenToR x y z) = (FromThenTo (cvtl loc x) (cvtl loc y) (cvtl loc z))
268 cvtstmts :: SrcSpan -> [TH.Stmt] -> [Hs.LStmt RdrName]
270 cvtstmts loc (NoBindS e : ss) = L loc (mkExprStmt (cvtl loc e)) : cvtstmts loc ss
271 cvtstmts loc (TH.BindS p e : ss) = L loc (mkBindStmt (cvtlp loc p) (cvtl loc e)) : cvtstmts loc ss
272 cvtstmts loc (TH.LetS ds : ss) = L loc (LetStmt (cvtdecs loc ds)) : cvtstmts loc ss
273 cvtstmts loc (TH.ParS dss : ss) = L loc (ParStmt [(cvtstmts loc ds, undefined) | ds <- dss]) : cvtstmts loc ss
275 cvtm :: SrcSpan -> TH.Match -> Hs.LMatch RdrName
276 cvtm loc (TH.Match p body wheres)
277 = L loc (Hs.Match [cvtlp loc p] Nothing (GRHSs (cvtguard loc body) (cvtdecs loc wheres)))
279 cvtguard :: SrcSpan -> TH.Body -> [LGRHS RdrName]
280 cvtguard loc (GuardedB pairs) = map (cvtpair loc) pairs
281 cvtguard loc (NormalB e) = [L loc (GRHS [] (cvtl loc e))]
283 cvtpair :: SrcSpan -> (TH.Guard,TH.Exp) -> LGRHS RdrName
284 cvtpair loc (NormalG x,y) = L loc (GRHS [L loc $ mkBindStmt truePat (cvtl loc x)]
286 cvtpair loc (PatG x,y) = L loc (GRHS (cvtstmts loc x) (cvtl loc y))
288 cvtOverLit :: Lit -> HsOverLit RdrName
289 cvtOverLit (IntegerL i) = mkHsIntegral i
290 cvtOverLit (RationalL r) = mkHsFractional r
291 -- An Integer is like an an (overloaded) '3' in a Haskell source program
292 -- Similarly 3.5 for fractionals
294 cvtLit :: Lit -> HsLit
295 cvtLit (IntPrimL i) = HsIntPrim i
296 cvtLit (FloatPrimL f) = HsFloatPrim f
297 cvtLit (DoublePrimL f) = HsDoublePrim f
298 cvtLit (CharL c) = HsChar c
299 cvtLit (StringL s) = HsString (mkFastString s)
301 cvtlp :: SrcSpan -> TH.Pat -> Hs.LPat RdrName
302 cvtlp loc pat = L loc (cvtp loc pat)
304 cvtp :: SrcSpan -> TH.Pat -> Hs.Pat RdrName
306 | overloadedLit l = mkNPat (cvtOverLit l) Nothing -- Not right for negative
307 -- patterns; need to think
309 | otherwise = Hs.LitPat (cvtLit l)
310 cvtp loc (TH.VarP s) = Hs.VarPat(vName s)
311 cvtp loc (TupP [p]) = cvtp loc p
312 cvtp loc (TupP ps) = TuplePat (map (cvtlp loc) ps) Boxed
313 cvtp loc (ConP s ps) = ConPatIn (L loc (cName s)) (PrefixCon (map (cvtlp loc) ps))
314 cvtp loc (InfixP p1 s p2)
315 = ConPatIn (L loc (cName s)) (InfixCon (cvtlp loc p1) (cvtlp loc p2))
316 cvtp loc (TildeP p) = LazyPat (cvtlp loc p)
317 cvtp loc (TH.AsP s p) = AsPat (L loc (vName s)) (cvtlp loc p)
318 cvtp loc TH.WildP = WildPat void
319 cvtp loc (RecP c fs) = ConPatIn (L loc (cName c)) $ Hs.RecCon (map (\(s,p) -> (L loc (vName s),cvtlp loc p)) fs)
320 cvtp loc (ListP ps) = ListPat (map (cvtlp loc) ps) void
321 cvtp loc (SigP p t) = SigPatIn (cvtlp loc p) (cvtType loc t)
323 -----------------------------------------------------------
324 -- Types and type variables
326 cvt_tvs :: SrcSpan -> [TH.Name] -> [LHsTyVarBndr RdrName]
327 cvt_tvs loc tvs = map (L loc . UserTyVar . tName) tvs
329 cvt_context :: SrcSpan -> Cxt -> LHsContext RdrName
330 cvt_context loc tys = L loc (map (L loc . cvt_pred loc) tys)
332 cvt_pred :: SrcSpan -> TH.Type -> HsPred RdrName
334 = case split_ty_app ty of
335 (ConT tc, tys) -> HsClassP (tconName tc) (map (cvtType loc) tys)
336 (VarT tv, tys) -> HsClassP (tName tv) (map (cvtType loc) tys)
337 other -> cvtPanic "Malformed predicate" (text (TH.pprint ty))
339 convertToHsType = cvtType
341 cvtType :: SrcSpan -> TH.Type -> LHsType RdrName
342 cvtType loc ty = trans (root ty [])
343 where root (AppT a b) zs = root a (cvtType loc b : zs)
346 trans (TupleT n,args)
347 | length args == n = L loc (HsTupleTy Boxed args)
348 | n == 0 = foldl nlHsAppTy (nlHsTyVar (getRdrName unitTyCon)) args
349 | otherwise = foldl nlHsAppTy (nlHsTyVar (getRdrName (tupleTyCon Boxed n))) args
350 trans (ArrowT, [x,y]) = nlHsFunTy x y
351 trans (ListT, [x]) = L loc (HsListTy x)
353 trans (VarT nm, args) = foldl nlHsAppTy (nlHsTyVar (tName nm)) args
354 trans (ConT tc, args) = foldl nlHsAppTy (nlHsTyVar (tconName tc)) args
356 trans (ForallT tvs cxt ty, []) = L loc $ mkExplicitHsForAllTy
357 (cvt_tvs loc tvs) (cvt_context loc cxt) (cvtType loc ty)
359 split_ty_app :: TH.Type -> (TH.Type, [TH.Type])
360 split_ty_app ty = go ty []
362 go (AppT f a) as = go f (a:as)
365 -----------------------------------------------------------
367 sigP (TH.SigD _ _) = True
371 -----------------------------------------------------------
372 cvtPanic :: String -> SDoc -> b
373 cvtPanic herald thing
374 = pprPanic herald (thing $$ ptext SLIT("When splicing generated code into the program"))
376 -----------------------------------------------------------
377 -- some useful things
379 truePat = nlConPat (getRdrName trueDataCon) []
381 overloadedLit :: Lit -> Bool
382 -- True for literals that Haskell treats as overloaded
383 overloadedLit (IntegerL l) = True
384 overloadedLit (RationalL l) = True
385 overloadedLit l = False
388 void = placeHolderType
390 --------------------------------------------------------------------
391 -- Turning Name back into RdrName
392 --------------------------------------------------------------------
395 vName :: TH.Name -> RdrName
396 vName = thRdrName OccName.varName
398 -- Constructor function names; this is Haskell source, hence srcDataName
399 cName :: TH.Name -> RdrName
400 cName = thRdrName OccName.srcDataName
402 -- Type variable names
403 tName :: TH.Name -> RdrName
404 tName = thRdrName OccName.tvName
406 -- Type Constructor names
407 tconName = thRdrName OccName.tcName
409 thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
410 -- This turns a Name into a RdrName
411 -- The passed-in name space tells what the context is expecting;
412 -- use it unless the TH name knows what name-space it comes
413 -- from, in which case use the latter
414 thRdrName ctxt_ns (TH.Name occ (TH.NameG th_ns mod)) = mkOrig (mk_mod mod) (mk_occ (mk_ghc_ns th_ns) occ)
415 thRdrName ctxt_ns (TH.Name occ (TH.NameL uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ctxt_ns occ) noSrcLoc)
416 thRdrName ctxt_ns (TH.Name occ (TH.NameQ mod)) = mkRdrQual (mk_mod mod) (mk_occ ctxt_ns occ)
417 thRdrName ctxt_ns (TH.Name occ TH.NameS) = mkRdrUnqual (mk_occ ctxt_ns occ)
418 thRdrName ctxt_ns (TH.Name occ (TH.NameU uniq)) = mkRdrUnqual (mk_uniq_occ ctxt_ns occ uniq)
420 mk_uniq_occ :: OccName.NameSpace -> TH.OccName -> Int# -> OccName.OccName
421 mk_uniq_occ ns occ uniq
422 = OccName.mkOccName ns (TH.occString occ ++ '[' : shows (mk_uniq uniq) "]")
423 -- The idea here is to make a name that
424 -- a) the user could not possibly write, and
425 -- b) cannot clash with another NameU
426 -- Previously I generated an Exact RdrName with mkInternalName.
427 -- This works fine for local binders, but does not work at all for
428 -- top-level binders, which must have External Names, since they are
429 -- rapidly baked into data constructors and the like. Baling out
430 -- and generating an unqualified RdrName here is the simple solution
432 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
433 mk_ghc_ns DataName = OccName.dataName
434 mk_ghc_ns TH.TcClsName = OccName.tcClsName
435 mk_ghc_ns TH.VarName = OccName.varName
437 -- The packing and unpacking is rather turgid :-(
438 mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName
439 mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
441 mk_mod :: TH.ModName -> Module
442 mk_mod mod = mkModule (TH.modString mod)
444 mk_uniq :: Int# -> Unique
445 mk_uniq u = mkUniqueGrimily (I# u)