Convert.lhs 16.5 KB
Newer Older
1
2
3
4
5
6
7
8
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

This module converts Template Haskell syntax into HsSyn


\begin{code}
9
module Convert( convertToHsExpr, convertToHsDecls, convertToHsType ) where
10
11
12

#include "HsVersions.h"

13
import Language.Haskell.TH as TH hiding (sigP)
14
import Language.Haskell.TH.Syntax as TH
15
16

import HsSyn as Hs
17
18
import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, nameRdrName, getRdrName )
import Module   ( ModuleName, mkModuleName )
19
import RdrHsSyn	( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
20
21
import Name	( mkInternalName )
import qualified OccName
22
23
import SrcLoc	( SrcLoc, generatedSrcLoc, noLoc, unLoc, Located(..),
		  noSrcSpan, SrcSpan, srcLocSpan, noSrcLoc )
24
import Type	( Type )
25
import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon, falseDataCon )
26
import BasicTypes( Boxity(..), RecFlag(Recursive) )
27
28
29
30
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
                     CExportSpec(..)) 
import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..),
                 ForeignDecl(..) )
31
32
import FastString( FastString, mkFastString, nilFS )
import Char 	( ord, isAscii, isAlphaNum, isAlpha )
33
import List	( partition )
34
import Unique	( Unique, mkUniqueGrimily )
35
import ErrUtils (Message)
36
import GLAEXTS	( Int#, Int(..) )
37
import Bag	( emptyBag, consBag )
38
39
40
41
import Outputable


-------------------------------------------------------------------
42
43
convertToHsDecls :: [TH.Dec] -> [Either (LHsDecl RdrName) Message]
convertToHsDecls ds = map cvt_ltop ds
44

45
46
47
mk_con con = L loc0 $ mk_nlcon con
  where
    mk_nlcon con = case con of
48
	NormalC c strtys
49
50
	 -> ConDecl (noLoc (cName c)) noExistentials noContext
		  (PrefixCon (map mk_arg strtys))
51
	RecC c varstrtys
52
53
	 -> ConDecl (noLoc (cName c)) noExistentials noContext
		  (RecCon (map mk_id_arg varstrtys))
54
	InfixC st1 c st2
55
56
	 -> ConDecl (noLoc (cName c)) noExistentials noContext
		  (InfixCon (mk_arg st1) (mk_arg st2))
57
58
59
60
61
62
	ForallC tvs ctxt (ForallC tvs' ctxt' con')
	 -> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
	ForallC tvs ctxt con' -> case mk_nlcon con' of
				ConDecl l [] (L _ []) x ->
				    ConDecl l (cvt_tvs tvs) (cvt_context ctxt) x
				c -> panic "ForallC: Can't happen"
63
    mk_arg (IsStrict, ty)  = noLoc $ HsBangTy HsStrict (cvtType ty)
64
    mk_arg (NotStrict, ty) = cvtType ty
65

66
    mk_id_arg (i, IsStrict, ty)
67
        = (noLoc (vName i), noLoc $ HsBangTy HsStrict (cvtType ty))
68
    mk_id_arg (i, NotStrict, ty)
69
        = (noLoc (vName i), cvtType ty)
70
71

mk_derivs [] = Nothing
72
mk_derivs cs = Just [noLoc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs]
73
74
75
76
77

cvt_ltop  :: TH.Dec -> Either (LHsDecl RdrName) Message
cvt_ltop d = case cvt_top d of
		Left d -> Left (L loc0 d)
		Right m -> Right m
78

79
cvt_top :: TH.Dec -> Either (HsDecl RdrName) Message
80
81
cvt_top d@(TH.ValD _ _ _) = Left $ Hs.ValD (unLoc (cvtd d))
cvt_top d@(TH.FunD _ _)   = Left $ Hs.ValD (unLoc (cvtd d))
82
 
83
cvt_top (TySynD tc tvs rhs)
84
  = Left $ TyClD (TySynonym (noLoc (tconName tc)) (cvt_tvs tvs) (cvtType rhs))
85

86
cvt_top (DataD ctxt tc tvs constrs derivs)
87
  = Left $ TyClD (mkTyData DataType 
88
89
                           (noLoc (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs))
                           Nothing (map mk_con constrs)
90
                           (mk_derivs derivs))
91

92
cvt_top (NewtypeD ctxt tc tvs constr derivs)
93
  = Left $ TyClD (mkTyData NewType 
94
95
                           (noLoc (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs))
                           Nothing [mk_con constr]
96
                           (mk_derivs derivs))
97

98
cvt_top (ClassD ctxt cl tvs decs)
99
  = Left $ TyClD (mkClassDecl (cvt_context ctxt, noLoc (tconName cl), cvt_tvs tvs)
100
                              noFunDeps sigs
101
			      binds)
102
103
104
  where
    (binds,sigs) = cvtBindsAndSigs decs

105
cvt_top (InstanceD tys ty decs)
106
  = Left $ InstD (InstDecl (noLoc inst_ty) binds sigs)
107
108
  where
    (binds, sigs) = cvtBindsAndSigs decs
109
    inst_ty = mkImplicitHsForAllTy (cvt_context tys) (noLoc (HsPredTy (cvt_pred ty)))
110

111
cvt_top (TH.SigD nm typ) = Left $ Hs.SigD (Sig (noLoc (vName nm)) (cvtType typ))
112

113
cvt_top (ForeignD (ImportF callconv safety from nm typ))
114
115
116
 = case parsed of
       Just (c_header, cis) ->
           let i = CImport callconv' safety' c_header nilFS cis
117
           in Left $ ForD (ForeignImport (noLoc (vName nm)) (cvtType typ) i False)
118
119
120
       Nothing -> Right $     text (show from)
                          <+> ptext SLIT("is not a valid ccall impent")
    where callconv' = case callconv of
121
122
123
124
125
126
                          CCall -> CCallConv
                          StdCall -> StdCallConv
          safety' = case safety of
                        Unsafe     -> PlayRisky
                        Safe       -> PlaySafe False
                        Threadsafe -> PlaySafe True
127
          parsed = parse_ccall_impent (TH.nameBase nm) from
128

129
130
cvt_top (ForeignD (ExportF callconv as nm typ))
 = let e = CExport (CExportStatic (mkFastString as) callconv')
131
   in Left $ ForD (ForeignExport (noLoc (vName nm)) (cvtType typ) e False)
132
133
134
135
    where callconv' = case callconv of
                          CCall -> CCallConv
                          StdCall -> StdCallConv

136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
parse_ccall_impent nm s
 = case lex_ccall_impent s of
       Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
       Just ["wrapper"] -> Just (nilFS, CWrapper)
       Just ("static":ts) -> parse_ccall_impent_static nm ts
       Just ts -> parse_ccall_impent_static nm ts
       Nothing -> Nothing

parse_ccall_impent_static :: String
                          -> [String]
                          -> Maybe (FastString, CImportSpec)
parse_ccall_impent_static nm ts
 = let ts' = case ts of
                 [       "&", cid] -> [       cid]
                 [fname, "&"     ] -> [fname     ]
                 [fname, "&", cid] -> [fname, cid]
                 _                 -> ts
   in case ts' of
          [       cid] | is_cid cid -> Just (nilFS,              mk_cid cid)
          [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
          [          ]              -> Just (nilFS,              mk_cid nm)
          [fname     ]              -> Just (mkFastString fname, mk_cid nm)
          _                         -> Nothing
    where is_cid :: String -> Bool
          is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
          mk_cid :: String -> CImportSpec
          mk_cid  = CFunction . StaticTarget . mkFastString

lex_ccall_impent :: String -> Maybe [String]
lex_ccall_impent "" = Just []
lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
lex_ccall_impent (' ':xs) = lex_ccall_impent xs
lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
lex_ccall_impent xs = case span is_valid xs of
                          ("", _) -> Nothing
                          (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
    where is_valid :: Char -> Bool
          is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
175

176
noContext      = noLoc []
177
178
179
180
noExistentials = []
noFunDeps      = []

-------------------------------------------------------------------
181
182
183
184
convertToHsExpr :: TH.Exp -> LHsExpr RdrName
convertToHsExpr = cvtl

cvtl e = noLoc (cvt e)
185

186
187
188
cvt (VarE s) 	  = HsVar (vName s)
cvt (ConE s) 	  = HsVar (cName s)
cvt (LitE l) 
189
190
191
  | overloadedLit l = HsOverLit (cvtOverLit l)
  | otherwise	    = HsLit (cvtLit l)

192
cvt (AppE x y)     = HsApp (cvtl x) (cvtl y)
193
cvt (LamE ps e)    = HsLam (mkMatchGroup [mkSimpleMatch (map cvtlp ps) (cvtl e)])
194
cvt (TupE [e])	  = cvt e
195
196
197
cvt (TupE es)	  = ExplicitTuple(map cvtl es) Boxed
cvt (CondE x y z)  = HsIf (cvtl x) (cvtl y) (cvtl z)
cvt (LetE ds e)	  = HsLet (cvtdecs ds) (cvtl e)
198
cvt (CaseE e ms)   = HsCase (cvtl e) (mkMatchGroup (map cvtm ms))
199
200
cvt (DoE ss)	  = HsDo DoExpr (cvtstmts ss) [] void
cvt (CompE ss)     = HsDo ListComp (cvtstmts ss) [] void
201
cvt (ArithSeqE dd) = ArithSeqIn (cvtdd dd)
202
cvt (ListE xs)  = ExplicitList void (map cvtl xs)
203
cvt (InfixE (Just x) s (Just y))
204
205
206
    = HsPar (noLoc $ OpApp (cvtl x) (cvtl s) undefined (cvtl y))
cvt (InfixE Nothing  s (Just y)) = SectionR (cvtl s) (cvtl y)
cvt (InfixE (Just x) s Nothing ) = SectionL (cvtl x) (cvtl s)
207
cvt (InfixE Nothing  s Nothing ) = cvt s	-- Can I indicate this is an infix thing?
208
209
210
cvt (SigE e t)		= ExprWithTySig (cvtl e) (cvtType t)
cvt (RecConE c flds) = RecordCon (noLoc (cName c)) (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds)
cvt (RecUpdE e flds) = RecordUpd (cvtl e) (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds)
211

212
213
214
cvtdecs :: [TH.Dec] -> [HsBindGroup RdrName]
cvtdecs [] = []
cvtdecs ds = [HsBindGroup binds sigs Recursive]
215
216
217
218
219
220
221
222
	   where
	     (binds, sigs) = cvtBindsAndSigs ds

cvtBindsAndSigs ds 
  = (cvtds non_sigs, map cvtSig sigs)
  where 
    (sigs, non_sigs) = partition sigP ds

223
cvtSig (TH.SigD nm typ) = noLoc (Hs.Sig (noLoc (vName nm)) (cvtType typ))
224

225
226
227
cvtds :: [TH.Dec] -> LHsBinds RdrName
cvtds []     = emptyBag
cvtds (d:ds) = cvtd d `consBag` cvtds ds
228

229
cvtd :: TH.Dec -> LHsBind RdrName
230
231
-- Used only for declarations in a 'let/where' clause,
-- not for top level decls
232
cvtd (TH.ValD (TH.VarP s) body ds) 
233
  = noLoc $ FunBind (noLoc (vName s)) False (mkMatchGroup [cvtclause (Clause [] body ds)])
234
cvtd (FunD nm cls)
235
  = noLoc $ FunBind (noLoc (vName nm)) False (mkMatchGroup (map cvtclause cls))
236
cvtd (TH.ValD p body ds)
237
  = noLoc $ PatBind (cvtlp p) (GRHSs (cvtguard body) (cvtdecs ds)) void
238
239

cvtd d = cvtPanic "Illegal kind of declaration in where clause" 
240
		  (text (TH.pprint d))
241
242


243
cvtclause :: TH.Clause -> Hs.LMatch RdrName
244
cvtclause (Clause ps body wheres)
245
    = noLoc $ Hs.Match (map cvtlp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres))
246
247
248



249
cvtdd :: Range -> ArithSeqInfo RdrName
250
251
252
253
cvtdd (FromR x) 	      = (From (cvtl x))
cvtdd (FromThenR x y)     = (FromThen (cvtl x) (cvtl y))
cvtdd (FromToR x y)	      = (FromTo (cvtl x) (cvtl y))
cvtdd (FromThenToR x y z) = (FromThenTo (cvtl x) (cvtl y) (cvtl z))
254
255


256
cvtstmts :: [TH.Stmt] -> [Hs.LStmt RdrName]
257
cvtstmts []		       = [] -- this is probably an error as every [stmt] should end with ResultStmt
258
259
260
261
262
cvtstmts [NoBindS e]           = [nlResultStmt (cvtl e)]      -- when its the last element use ResultStmt
cvtstmts (NoBindS e : ss)      = nlExprStmt (cvtl e)     : cvtstmts ss
cvtstmts (TH.BindS p e : ss) = nlBindStmt (cvtlp p) (cvtl e) : cvtstmts ss
cvtstmts (TH.LetS ds : ss)   = nlLetStmt (cvtdecs ds)	    : cvtstmts ss
cvtstmts (TH.ParS dss : ss)  = nlParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss
263

264
cvtm :: TH.Match -> Hs.LMatch RdrName
265
cvtm (TH.Match p body wheres)
266
    = noLoc (Hs.Match [cvtlp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres)))
267
268

cvtguard :: TH.Body -> [LGRHS RdrName]
269
cvtguard (GuardedB pairs) = map cvtpair pairs
270
cvtguard (NormalB e) 	 = [noLoc (GRHS [  nlResultStmt (cvtl e) ])]
271

272
273
274
275
cvtpair :: (TH.Guard,TH.Exp) -> LGRHS RdrName
cvtpair (NormalG x,y) = noLoc (GRHS [nlBindStmt truePat (cvtl x),
                               nlResultStmt (cvtl y)])
cvtpair (PatG x,y) = noLoc (GRHS (cvtstmts x ++ [nlResultStmt (cvtl y)]))
276
277

cvtOverLit :: Lit -> HsOverLit
278
279
cvtOverLit (IntegerL i)  = mkHsIntegral i
cvtOverLit (RationalL r) = mkHsFractional r
280
-- An Integer is like an an (overloaded) '3' in a Haskell source program
281
-- Similarly 3.5 for fractionals
282
283

cvtLit :: Lit -> HsLit
284
285
286
cvtLit (IntPrimL i)    = HsIntPrim i
cvtLit (FloatPrimL f)  = HsFloatPrim f
cvtLit (DoublePrimL f) = HsDoublePrim f
287
cvtLit (CharL c)       = HsChar c
288
cvtLit (StringL s)     = HsString (mkFastString s)
289

290
291
292
cvtlp :: TH.Pat -> Hs.LPat RdrName
cvtlp pat = noLoc (cvtp pat)

293
294
cvtp :: TH.Pat -> Hs.Pat RdrName
cvtp (TH.LitP l)
295
296
297
  | overloadedLit l = NPatIn (cvtOverLit l) Nothing	-- Not right for negative
							-- patterns; need to think
							-- about that!
298
  | otherwise	    = Hs.LitPat (cvtLit l)
299
cvtp (TH.VarP s)     = Hs.VarPat(vName s)
300
cvtp (TupP [p])   = cvtp p
301
302
cvtp (TupP ps)    = TuplePat (map cvtlp ps) Boxed
cvtp (ConP s ps)  = ConPatIn (noLoc (cName s)) (PrefixCon (map cvtlp ps))
303
304
cvtp (InfixP p1 s p2)
                  = ConPatIn (noLoc (cName s)) (InfixCon (cvtlp p1) (cvtlp p2))
305
306
cvtp (TildeP p)   = LazyPat (cvtlp p)
cvtp (TH.AsP s p) = AsPat (noLoc (vName s)) (cvtlp p)
307
cvtp TH.WildP   = WildPat void
308
309
cvtp (RecP c fs)  = ConPatIn (noLoc (cName c)) $ Hs.RecCon (map (\(s,p) -> (noLoc (vName s),cvtlp p)) fs)
cvtp (ListP ps)   = ListPat (map cvtlp ps) void
310
cvtp (SigP p t)   = SigPatIn (cvtlp p) (cvtType t)
311
312
313
314

-----------------------------------------------------------
--	Types and type variables

315
316
cvt_tvs :: [TH.Name] -> [LHsTyVarBndr RdrName]
cvt_tvs tvs = map (noLoc . UserTyVar . tName) tvs
317

318
cvt_context :: Cxt -> LHsContext RdrName 
319
cvt_context tys = noLoc (map (noLoc . cvt_pred) tys)
320

321
cvt_pred :: TH.Type -> HsPred RdrName
322
cvt_pred ty = case split_ty_app ty of
323
324
	   	(ConT tc, tys) -> HsClassP (tconName tc) (map cvtType tys)
	   	(VarT tv, tys) -> HsClassP (tName tv) (map cvtType tys)
325
		other -> cvtPanic "Malformed predicate" (text (TH.pprint ty))
326

327
328
convertToHsType = cvtType

329
cvtType :: TH.Type -> LHsType RdrName
330
cvtType ty = trans (root ty [])
331
  where root (AppT a b) zs = root a (cvtType b : zs)
332
333
        root t zs 	   = (t,zs)

334
        trans (TupleT n,args)
335
336
337
338
339
            | length args == n = noLoc (HsTupleTy Boxed args)
            | n == 0    = foldl nlHsAppTy (nlHsTyVar (getRdrName unitTyCon))	    args
            | otherwise = foldl nlHsAppTy (nlHsTyVar (getRdrName (tupleTyCon Boxed n))) args
        trans (ArrowT,   [x,y]) = nlHsFunTy x y
        trans (ListT,    [x])   = noLoc (HsListTy x)
340

341
342
	trans (VarT nm, args)	    = foldl nlHsAppTy (nlHsTyVar (tName nm))    args
        trans (ConT tc, args)       = foldl nlHsAppTy (nlHsTyVar (tconName tc)) args
343

344
	trans (ForallT tvs cxt ty, []) = noLoc $ mkExplicitHsForAllTy 
345
						(cvt_tvs tvs) (cvt_context cxt) (cvtType ty)
346

347
split_ty_app :: TH.Type -> (TH.Type, [TH.Type])
348
349
split_ty_app ty = go ty []
  where
350
    go (AppT f a) as = go f (a:as)
351
352
353
354
    go f as 	     = (f,as)

-----------------------------------------------------------
sigP :: Dec -> Bool
355
sigP (TH.SigD _ _) = True
356
357
358
sigP other	 = False


359
360
361
362
363
-----------------------------------------------------------
cvtPanic :: String -> SDoc -> b
cvtPanic herald thing
  = pprPanic herald (thing $$ ptext SLIT("When splicing generated code into the program"))

364
365
366
-----------------------------------------------------------
-- some useful things

367
368
truePat  = nlConPat (getRdrName trueDataCon)  []
falsePat = nlConPat (getRdrName falseDataCon) []
369
370
371

overloadedLit :: Lit -> Bool
-- True for literals that Haskell treats as overloaded
372
373
374
overloadedLit (IntegerL  l) = True
overloadedLit (RationalL l) = True
overloadedLit l	            = False
375
376
377
378

void :: Type.Type
void = placeHolderType

379
380
loc0 :: SrcSpan
loc0 = srcLocSpan generatedSrcLoc
381

382
383
384
385
--------------------------------------------------------------------
--	Turning Name back into RdrName
--------------------------------------------------------------------

386
-- variable names
387
vName :: TH.Name -> RdrName
388
vName = thRdrName OccName.varName
389

390
-- Constructor function names; this is Haskell source, hence srcDataName
391
cName :: TH.Name -> RdrName
392
cName = thRdrName OccName.srcDataName
393
394

-- Type variable names
395
tName :: TH.Name -> RdrName
396
tName = thRdrName OccName.tvName
397
398

-- Type Constructor names
399
tconName = thRdrName OccName.tcName
400

401
thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
402
403
404
405
406
407
-- This turns a Name into a RdrName
-- The last case is slightly interesting.  It constructs a
-- unique name from the unique in the TH thingy, so that the renamer
-- won't mess about.  I hope.  (Another possiblity would be to generate 
-- "x_77" etc, but that could conceivably clash.)

408
thRdrName ns (TH.Name occ (TH.NameG ns' mod))  = mkOrig (mk_mod mod) (mk_occ ns occ)
409
thRdrName ns (TH.Name occ TH.NameS)            = mkDynName ns occ
410
thRdrName ns (TH.Name occ (TH.NameU uniq))     = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ns occ) noSrcLoc)
411
412
413
414
415
416
417
418
419
420

mk_uniq :: Int# -> Unique
mk_uniq u = mkUniqueGrimily (I# u)

-- The packing and unpacking is rather turgid :-(
mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName
mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))

mk_mod :: TH.ModName -> ModuleName
mk_mod mod = mkModuleName (TH.modString mod)
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437

mkDynName :: OccName.NameSpace -> TH.OccName -> RdrName
-- Parse the string to see if it has a "." in it
-- so we know whether to generate a qualified or unqualified name
-- It's a bit tricky because we need to parse 
--	Foo.Baz.x as Qual Foo.Baz x
-- So we parse it from back to front

mkDynName ns th_occ
  = split [] (reverse (TH.occString th_occ))
  where
    split occ []        = mkRdrUnqual (mk_occ occ)
    split occ ('.':rev)	= mkRdrQual (mk_mod (reverse rev)) (mk_occ occ)
    split occ (c:rev)   = split (c:occ) rev

    mk_occ occ = OccName.mkOccFS ns (mkFastString occ)
    mk_mod mod = mkModuleName mod
438
\end{code}
439