Convert.lhs 16.1 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
import qualified Class (FunDep)
18
import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName )
19
import Module   ( Module, mkModule )
20
import RdrHsSyn	( mkClassDecl, mkTyData )
21
import qualified OccName
22
23
import SrcLoc	( generatedSrcLoc, noLoc, unLoc, Located(..),
		  SrcSpan, srcLocSpan )
24
import Type	( Type )
25
import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon )
26
import BasicTypes( Boxity(..), RecFlag(Recursive) )
27
28
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
                     CExportSpec(..)) 
29
import Char 	( isAscii, isAlphaNum, isAlpha )
30
import List	( partition )
31
import Unique	( mkUniqueGrimily )
32
import ErrUtils (Message)
33
import GLAEXTS	( Int(..) )
34
import Bag	( emptyBag, consBag )
35
import FastString
36
37
38
39
import Outputable


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

43
44
45
mk_con con = L loc0 $ mk_nlcon con
  where
    mk_nlcon con = case con of
46
	NormalC c strtys
47
48
	 -> ConDecl (noLoc (cName c)) noExistentials noContext
		  (PrefixCon (map mk_arg strtys))
49
	RecC c varstrtys
50
51
	 -> ConDecl (noLoc (cName c)) noExistentials noContext
		  (RecCon (map mk_id_arg varstrtys))
52
	InfixC st1 c st2
53
54
	 -> ConDecl (noLoc (cName c)) noExistentials noContext
		  (InfixCon (mk_arg st1) (mk_arg st2))
55
56
57
58
59
60
	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"
61
    mk_arg (IsStrict, ty)  = noLoc $ HsBangTy HsStrict (cvtType ty)
62
    mk_arg (NotStrict, ty) = cvtType ty
63

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

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

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
76

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

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

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

96
97
98
99
100
101
102
cvt_top (ClassD ctxt cl tvs fds decs)
  = Left $ TyClD $ mkClassDecl (cvt_context ctxt,
                                noLoc (tconName cl),
                                cvt_tvs tvs)
                               (map (noLoc . cvt_fundep) fds)
                               sigs
                               binds
103
104
105
  where
    (binds,sigs) = cvtBindsAndSigs decs

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

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

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

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

137
138
139
cvt_fundep :: FunDep -> Class.FunDep RdrName
cvt_fundep (FunDep xs ys) = (map tName xs, map tName ys)

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
175
176
177
178
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` "._")
179

180
noContext      = noLoc []
181
182
183
noExistentials = []

-------------------------------------------------------------------
184
185
186
187
convertToHsExpr :: TH.Exp -> LHsExpr RdrName
convertToHsExpr = cvtl

cvtl e = noLoc (cvt e)
188

189
190
191
cvt (VarE s) 	  = HsVar (vName s)
cvt (ConE s) 	  = HsVar (cName s)
cvt (LitE l) 
192
193
194
  | overloadedLit l = HsOverLit (cvtOverLit l)
  | otherwise	    = HsLit (cvtLit l)

195
cvt (AppE x y)     = HsApp (cvtl x) (cvtl y)
196
cvt (LamE ps e)    = HsLam (mkMatchGroup [mkSimpleMatch (map cvtlp ps) (cvtl e)])
197
cvt (TupE [e])	  = cvt e
198
199
200
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)
201
cvt (CaseE e ms)   = HsCase (cvtl e) (mkMatchGroup (map cvtm ms))
202
203
cvt (DoE ss)	  = HsDo DoExpr (cvtstmts ss) [] void
cvt (CompE ss)     = HsDo ListComp (cvtstmts ss) [] void
204
cvt (ArithSeqE dd) = ArithSeqIn (cvtdd dd)
205
cvt (ListE xs)  = ExplicitList void (map cvtl xs)
206
cvt (InfixE (Just x) s (Just y))
207
208
209
    = 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)
210
cvt (InfixE Nothing  s Nothing ) = cvt s	-- Can I indicate this is an infix thing?
211
212
213
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)
214

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

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

226
cvtSig (TH.SigD nm typ) = noLoc (Hs.Sig (noLoc (vName nm)) (cvtType typ))
227

228
229
230
cvtds :: [TH.Dec] -> LHsBinds RdrName
cvtds []     = emptyBag
cvtds (d:ds) = cvtd d `consBag` cvtds ds
231

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

cvtd d = cvtPanic "Illegal kind of declaration in where clause" 
243
		  (text (TH.pprint d))
244
245


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



252
cvtdd :: Range -> ArithSeqInfo RdrName
253
254
255
256
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))
257
258


259
cvtstmts :: [TH.Stmt] -> [Hs.LStmt RdrName]
260
cvtstmts []		       = [] -- this is probably an error as every [stmt] should end with ResultStmt
261
262
263
264
265
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
266

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

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

275
276
277
278
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)]))
279
280

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

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

293
294
295
cvtlp :: TH.Pat -> Hs.LPat RdrName
cvtlp pat = noLoc (cvtp pat)

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

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

318
319
cvt_tvs :: [TH.Name] -> [LHsTyVarBndr RdrName]
cvt_tvs tvs = map (noLoc . UserTyVar . tName) tvs
320

321
cvt_context :: Cxt -> LHsContext RdrName 
322
cvt_context tys = noLoc (map (noLoc . cvt_pred) tys)
323

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

330
331
convertToHsType = cvtType

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

337
        trans (TupleT n,args)
338
339
340
341
342
            | 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)
343

344
345
	trans (VarT nm, args)	    = foldl nlHsAppTy (nlHsTyVar (tName nm))    args
        trans (ConT tc, args)       = foldl nlHsAppTy (nlHsTyVar (tconName tc)) args
346

347
	trans (ForallT tvs cxt ty, []) = noLoc $ mkExplicitHsForAllTy 
348
						(cvt_tvs tvs) (cvt_context cxt) (cvtType ty)
349

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

-----------------------------------------------------------
sigP :: Dec -> Bool
358
sigP (TH.SigD _ _) = True
359
360
361
sigP other	 = False


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

367
368
369
-----------------------------------------------------------
-- some useful things

370
truePat  = nlConPat (getRdrName trueDataCon)  []
371
372
373

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

void :: Type.Type
void = placeHolderType

381
382
loc0 :: SrcSpan
loc0 = srcLocSpan generatedSrcLoc
383

384
385
386
387
--------------------------------------------------------------------
--	Turning Name back into RdrName
--------------------------------------------------------------------

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

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

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

-- Type Constructor names
401
tconName = thRdrName OccName.tcName
402

403
thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
404
405
-- This turns a Name into a RdrName

406
407
408
thRdrName ns (TH.Name occ TH.NameS)           = mkRdrUnqual (mk_occ ns occ)
thRdrName ns (TH.Name occ (TH.NameQ mod))     = mkRdrQual (mk_mod mod) (mk_occ ns occ)
thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig    (mk_mod mod) (mk_occ ns occ)
409
410
411
412
413
414
415
416
417
418
419
420
thRdrName ns (TH.Name occ (TH.NameU uniq))    
  = mkRdrUnqual (OccName.mkOccName ns uniq_str)
  where
    uniq_str = TH.occString occ ++ '[' : shows (mkUniqueGrimily (I# uniq)) "]"
	-- The idea here is to make a name that 
	-- a) the user could not possibly write, and
	-- b) cannot clash with another NameU
	-- Previously I generated an Exact RdrName with mkInternalName.
	-- This works fine for local binders, but does not work at all for
	-- top-level binders, which must have External Names, since they are
	-- rapidly baked into data constructors and the like.  Baling out
	-- and generating an unqualified RdrName here is the simple solution
421
422
423
424
425

-- 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))

426
427
mk_mod :: TH.ModName -> Module
mk_mod mod = mkModule (TH.modString mod)
428
\end{code}
429