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 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] -> HsLocalBinds RdrName
225 cvtdecs loc [] = EmptyLocalBinds
226 cvtdecs loc ds = HsValBinds (ValBindsIn binds sigs)
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
246 (mkMatchGroup [cvtclause loc (Clause [] body ds)])
248 cvtd loc (FunD nm cls)
249 = L loc $ FunBind (L loc (vName nm)) False
250 (mkMatchGroup (map (cvtclause loc) cls))
252 cvtd loc (TH.ValD p body ds)
253 = L loc $ PatBind (cvtlp loc p) (GRHSs (cvtguard loc body) (cvtdecs loc ds))
254 void placeHolderNames
256 cvtd loc d = cvtPanic "Illegal kind of declaration in where clause"
260 cvtclause :: SrcSpan -> TH.Clause -> Hs.LMatch RdrName
261 cvtclause loc (Clause ps body wheres)
262 = L loc $ Hs.Match (map (cvtlp loc) ps) Nothing (GRHSs (cvtguard loc body) (cvtdecs loc wheres))
266 cvtdd :: SrcSpan -> Range -> ArithSeqInfo RdrName
267 cvtdd loc (FromR x) = (From (cvtl loc x))
268 cvtdd loc (FromThenR x y) = (FromThen (cvtl loc x) (cvtl loc y))
269 cvtdd loc (FromToR x y) = (FromTo (cvtl loc x) (cvtl loc y))
270 cvtdd loc (FromThenToR x y z) = (FromThenTo (cvtl loc x) (cvtl loc y) (cvtl loc z))
273 cvtstmts :: SrcSpan -> [TH.Stmt] -> [Hs.LStmt RdrName]
275 cvtstmts loc (NoBindS e : ss) = L loc (mkExprStmt (cvtl loc e)) : cvtstmts loc ss
276 cvtstmts loc (TH.BindS p e : ss) = L loc (mkBindStmt (cvtlp loc p) (cvtl loc e)) : cvtstmts loc ss
277 cvtstmts loc (TH.LetS ds : ss) = L loc (LetStmt (cvtdecs loc ds)) : cvtstmts loc ss
278 cvtstmts loc (TH.ParS dss : ss) = L loc (ParStmt [(cvtstmts loc ds, undefined) | ds <- dss]) : cvtstmts loc ss
280 cvtm :: SrcSpan -> TH.Match -> Hs.LMatch RdrName
281 cvtm loc (TH.Match p body wheres)
282 = L loc (Hs.Match [cvtlp loc p] Nothing (GRHSs (cvtguard loc body) (cvtdecs loc wheres)))
284 cvtguard :: SrcSpan -> TH.Body -> [LGRHS RdrName]
285 cvtguard loc (GuardedB pairs) = map (cvtpair loc) pairs
286 cvtguard loc (NormalB e) = [L loc (GRHS [] (cvtl loc e))]
288 cvtpair :: SrcSpan -> (TH.Guard,TH.Exp) -> LGRHS RdrName
289 cvtpair loc (NormalG x,y) = L loc (GRHS [L loc $ mkBindStmt truePat (cvtl loc x)]
291 cvtpair loc (PatG x,y) = L loc (GRHS (cvtstmts loc x) (cvtl loc y))
293 cvtOverLit :: Lit -> HsOverLit RdrName
294 cvtOverLit (IntegerL i) = mkHsIntegral i
295 cvtOverLit (RationalL r) = mkHsFractional r
296 -- An Integer is like an an (overloaded) '3' in a Haskell source program
297 -- Similarly 3.5 for fractionals
299 cvtLit :: Lit -> HsLit
300 cvtLit (IntPrimL i) = HsIntPrim i
301 cvtLit (FloatPrimL f) = HsFloatPrim f
302 cvtLit (DoublePrimL f) = HsDoublePrim f
303 cvtLit (CharL c) = HsChar c
304 cvtLit (StringL s) = HsString (mkFastString s)
306 cvtlp :: SrcSpan -> TH.Pat -> Hs.LPat RdrName
307 cvtlp loc pat = L loc (cvtp loc pat)
309 cvtp :: SrcSpan -> TH.Pat -> Hs.Pat RdrName
311 | overloadedLit l = mkNPat (cvtOverLit l) Nothing -- Not right for negative
312 -- patterns; need to think
314 | otherwise = Hs.LitPat (cvtLit l)
315 cvtp loc (TH.VarP s) = Hs.VarPat(vName s)
316 cvtp loc (TupP [p]) = cvtp loc p
317 cvtp loc (TupP ps) = TuplePat (map (cvtlp loc) ps) Boxed
318 cvtp loc (ConP s ps) = ConPatIn (L loc (cName s)) (PrefixCon (map (cvtlp loc) ps))
319 cvtp loc (InfixP p1 s p2)
320 = ConPatIn (L loc (cName s)) (InfixCon (cvtlp loc p1) (cvtlp loc p2))
321 cvtp loc (TildeP p) = LazyPat (cvtlp loc p)
322 cvtp loc (TH.AsP s p) = AsPat (L loc (vName s)) (cvtlp loc p)
323 cvtp loc TH.WildP = WildPat void
324 cvtp loc (RecP c fs) = ConPatIn (L loc (cName c)) $ Hs.RecCon (map (\(s,p) -> (L loc (vName s),cvtlp loc p)) fs)
325 cvtp loc (ListP ps) = ListPat (map (cvtlp loc) ps) void
326 cvtp loc (SigP p t) = SigPatIn (cvtlp loc p) (cvtType loc t)
328 -----------------------------------------------------------
329 -- Types and type variables
331 cvt_tvs :: SrcSpan -> [TH.Name] -> [LHsTyVarBndr RdrName]
332 cvt_tvs loc tvs = map (L loc . UserTyVar . tName) tvs
334 cvt_context :: SrcSpan -> Cxt -> LHsContext RdrName
335 cvt_context loc tys = L loc (map (L loc . cvt_pred loc) tys)
337 cvt_pred :: SrcSpan -> TH.Type -> HsPred RdrName
339 = case split_ty_app ty of
340 (ConT tc, tys) -> HsClassP (tconName tc) (map (cvtType loc) tys)
341 (VarT tv, tys) -> HsClassP (tName tv) (map (cvtType loc) tys)
342 other -> cvtPanic "Malformed predicate" (text (TH.pprint ty))
344 convertToHsType = cvtType
346 cvtType :: SrcSpan -> TH.Type -> LHsType RdrName
347 cvtType loc ty = trans (root ty [])
348 where root (AppT a b) zs = root a (cvtType loc b : zs)
351 trans (TupleT n,args)
352 | length args == n = L loc (HsTupleTy Boxed args)
353 | n == 0 = foldl nlHsAppTy (nlHsTyVar (getRdrName unitTyCon)) args
354 | otherwise = foldl nlHsAppTy (nlHsTyVar (getRdrName (tupleTyCon Boxed n))) args
355 trans (ArrowT, [x,y]) = nlHsFunTy x y
356 trans (ListT, [x]) = L loc (HsListTy x)
358 trans (VarT nm, args) = foldl nlHsAppTy (nlHsTyVar (tName nm)) args
359 trans (ConT tc, args) = foldl nlHsAppTy (nlHsTyVar (tconName tc)) args
361 trans (ForallT tvs cxt ty, []) = L loc $ mkExplicitHsForAllTy
362 (cvt_tvs loc tvs) (cvt_context loc cxt) (cvtType loc ty)
364 split_ty_app :: TH.Type -> (TH.Type, [TH.Type])
365 split_ty_app ty = go ty []
367 go (AppT f a) as = go f (a:as)
370 -----------------------------------------------------------
372 sigP (TH.SigD _ _) = True
376 -----------------------------------------------------------
377 cvtPanic :: String -> SDoc -> b
378 cvtPanic herald thing
379 = pprPanic herald (thing $$ ptext SLIT("When splicing generated code into the program"))
381 -----------------------------------------------------------
382 -- some useful things
384 truePat = nlConPat (getRdrName trueDataCon) []
386 overloadedLit :: Lit -> Bool
387 -- True for literals that Haskell treats as overloaded
388 overloadedLit (IntegerL l) = True
389 overloadedLit (RationalL l) = True
390 overloadedLit l = False
393 void = placeHolderType
395 --------------------------------------------------------------------
396 -- Turning Name back into RdrName
397 --------------------------------------------------------------------
400 vName :: TH.Name -> RdrName
401 vName = thRdrName OccName.varName
403 -- Constructor function names; this is Haskell source, hence srcDataName
404 cName :: TH.Name -> RdrName
405 cName = thRdrName OccName.srcDataName
407 -- Type variable names
408 tName :: TH.Name -> RdrName
409 tName = thRdrName OccName.tvName
411 -- Type Constructor names
412 tconName = thRdrName OccName.tcName
414 thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
415 -- This turns a Name into a RdrName
416 -- The passed-in name space tells what the context is expecting;
417 -- use it unless the TH name knows what name-space it comes
418 -- from, in which case use the latter
419 thRdrName ctxt_ns (TH.Name occ (TH.NameG th_ns mod)) = mkOrig (mk_mod mod) (mk_occ (mk_ghc_ns th_ns) occ)
420 thRdrName ctxt_ns (TH.Name occ (TH.NameL uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ctxt_ns occ) noSrcLoc)
421 thRdrName ctxt_ns (TH.Name occ (TH.NameQ mod)) = mkRdrQual (mk_mod mod) (mk_occ ctxt_ns occ)
422 thRdrName ctxt_ns (TH.Name occ TH.NameS) = mkRdrUnqual (mk_occ ctxt_ns occ)
423 thRdrName ctxt_ns (TH.Name occ (TH.NameU uniq)) = mkRdrUnqual (mk_uniq_occ ctxt_ns occ uniq)
425 mk_uniq_occ :: OccName.NameSpace -> TH.OccName -> Int# -> OccName.OccName
426 mk_uniq_occ ns occ uniq
427 = OccName.mkOccName ns (TH.occString occ ++ '[' : shows (mk_uniq uniq) "]")
428 -- The idea here is to make a name that
429 -- a) the user could not possibly write, and
430 -- b) cannot clash with another NameU
431 -- Previously I generated an Exact RdrName with mkInternalName.
432 -- This works fine for local binders, but does not work at all for
433 -- top-level binders, which must have External Names, since they are
434 -- rapidly baked into data constructors and the like. Baling out
435 -- and generating an unqualified RdrName here is the simple solution
437 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
438 mk_ghc_ns DataName = OccName.dataName
439 mk_ghc_ns TH.TcClsName = OccName.tcClsName
440 mk_ghc_ns TH.VarName = OccName.varName
442 -- The packing and unpacking is rather turgid :-(
443 mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName
444 mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
446 mk_mod :: TH.ModName -> Module
447 mk_mod mod = mkModule (TH.modString mod)
449 mk_uniq :: Int# -> Unique
450 mk_uniq u = mkUniqueGrimily (I# u)