Convert.lhs 14.3 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

This module converts Template Haskell syntax into HsSyn


\begin{code}
module Convert( convertToHsExpr, convertToHsDecls ) where

#include "HsVersions.h"

import Language.Haskell.THSyntax as Meta

import HsSyn as Hs
	(	HsExpr(..), HsLit(..), ArithSeqInfo(..), 
17
		HsStmtContext(..), TyClDecl(..), HsBang(..),
18
		Match(..), GRHSs(..), GRHS(..), HsPred(..),
chak's avatar
chak committed
19
		HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
20
21
		Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
		Pat(..), HsConDetails(..), HsOverLit, BangType(..),
22
		placeHolderType, HsType(..), HsExplicitForAll(..),
23
		HsTyVarBndr(..), HsContext,
24
		mkSimpleMatch, mkImplicitHsForAllTy, mkExplicitHsForAllTy
25
26
27
28
	) 

import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig )
import Module   ( mkModuleName )
29
import RdrHsSyn	( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
30
31
32
import OccName
import SrcLoc	( SrcLoc, generatedSrcLoc )
import Type	( Type )
33
import BasicTypes( Boxity(..), RecFlag(Recursive), NewOrData(..) )
34
35
36
37
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
                     CExportSpec(..)) 
import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..),
                 ForeignDecl(..) )
38
39
import FastString( FastString, mkFastString, nilFS )
import Char 	( ord, isAscii, isAlphaNum, isAlpha )
40
import List	( partition )
41
import ErrUtils (Message)
42
43
44
45
import Outputable


-------------------------------------------------------------------
46
convertToHsDecls :: [Meta.Dec] -> [Either (HsDecl RdrName) Message]
47
48
convertToHsDecls ds = map cvt_top ds

49
mk_con con = case con of
50
	NormalC c strtys
51
52
	 -> ConDecl (cName c) noExistentials noContext
		  (PrefixCon (map mk_arg strtys)) loc0
53
	RecC c varstrtys
54
	 -> ConDecl (cName c) noExistentials noContext
55
56
		  (RecCon (map mk_id_arg varstrtys)) loc0
	InfixC st1 c st2
57
	 -> ConDecl (cName c) noExistentials noContext
58
		  (InfixCon (mk_arg st1) (mk_arg st2)) loc0
59
  where
60
61
    mk_arg (IsStrict, ty)  = BangType HsStrict (cvtType ty)
    mk_arg (NotStrict, ty) = BangType HsNoBang (cvtType ty)
62

63
    mk_id_arg (i, IsStrict, ty)
64
        = (vName i, BangType HsStrict (cvtType ty))
65
    mk_id_arg (i, NotStrict, ty)
66
        = (vName i, BangType HsNoBang (cvtType ty))
67
68
69

mk_derivs [] = Nothing
mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]
70

71
cvt_top :: Meta.Dec -> Either (HsDecl RdrName) Message
72
73
cvt_top d@(Meta.ValD _ _ _) = Left $ Hs.ValD (cvtd d)
cvt_top d@(Meta.FunD _ _)   = Left $ Hs.ValD (cvtd d)
74
 
75
cvt_top (TySynD tc tvs rhs)
76
  = Left $ TyClD (TySynonym (tconName tc) (cvt_tvs tvs) (cvtType rhs) loc0)
77

78
cvt_top (DataD ctxt tc tvs constrs derivs)
79
  = Left $ TyClD (mkTyData DataType 
80
                           (cvt_context ctxt, tconName tc, cvt_tvs tvs)
81
                           (map mk_con constrs)
82
                           (mk_derivs derivs) loc0)
83

84
cvt_top (NewtypeD ctxt tc tvs constr derivs)
85
86
  = Left $ TyClD (mkTyData NewType 
                           (cvt_context ctxt, tconName tc, cvt_tvs tvs)
87
                           [mk_con constr]
88
                           (mk_derivs derivs) loc0)
89

90
cvt_top (ClassD ctxt cl tvs decs)
91
  = Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs)
92
                              noFunDeps sigs
93
			      binds loc0)
94
95
96
  where
    (binds,sigs) = cvtBindsAndSigs decs

97
cvt_top (InstanceD tys ty decs)
98
  = Left $ InstD (InstDecl inst_ty binds sigs loc0)
99
100
  where
    (binds, sigs) = cvtBindsAndSigs decs
101
    inst_ty = mkImplicitHsForAllTy (cvt_context tys) (HsPredTy (cvt_pred ty))
102

103
cvt_top (Meta.SigD nm typ) = Left $ Hs.SigD (Sig (vName nm) (cvtType typ) loc0)
104

105
cvt_top (ForeignD (ImportF callconv safety from nm typ))
106
107
108
109
110
111
112
 = case parsed of
       Just (c_header, cis) ->
           let i = CImport callconv' safety' c_header nilFS cis
           in Left $ ForD (ForeignImport (vName nm) (cvtType typ) i False loc0)
       Nothing -> Right $     text (show from)
                          <+> ptext SLIT("is not a valid ccall impent")
    where callconv' = case callconv of
113
114
115
116
117
118
                          CCall -> CCallConv
                          StdCall -> StdCallConv
          safety' = case safety of
                        Unsafe     -> PlayRisky
                        Safe       -> PlaySafe False
                        Threadsafe -> PlaySafe True
119
120
          parsed = parse_ccall_impent nm from

121
122
123
124
125
126
127
cvt_top (ForeignD (ExportF callconv as nm typ))
 = let e = CExport (CExportStatic (mkFastString as) callconv')
   in Left $ ForD (ForeignExport (vName nm) (cvtType typ) e False loc0)
    where callconv' = case callconv of
                          CCall -> CCallConv
                          StdCall -> StdCallConv

128
129
130
131
132
133
134
135
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
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` "._")
167

168
169
170
171
172
173
174
175
noContext      = []
noExistentials = []
noFunDeps      = []

-------------------------------------------------------------------
convertToHsExpr :: Meta.Exp -> HsExpr RdrName
convertToHsExpr = cvt

176
177
178
cvt (VarE s) 	  = HsVar (vName s)
cvt (ConE s) 	  = HsVar (cName s)
cvt (LitE l) 
179
180
181
  | overloadedLit l = HsOverLit (cvtOverLit l)
  | otherwise	    = HsLit (cvtLit l)

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

cvtdecs :: [Meta.Dec] -> HsBinds RdrName
cvtdecs [] = EmptyBinds
cvtdecs ds = MonoBind binds sigs Recursive
	   where
	     (binds, sigs) = cvtBindsAndSigs ds

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

213
cvtSig (Meta.SigD nm typ) = Hs.Sig (vName nm) (cvtType typ) loc0
214
215
216
217
218
219
220
221

cvtds :: [Meta.Dec] -> MonoBinds RdrName
cvtds []     = EmptyMonoBinds
cvtds (d:ds) = AndMonoBinds (cvtd d) (cvtds ds)

cvtd :: Meta.Dec -> MonoBinds RdrName
-- Used only for declarations in a 'let/where' clause,
-- not for top level decls
222
cvtd (Meta.ValD (Meta.VarP s) body ds) = FunMonoBind (vName s) False 
223
					  [cvtclause (Clause [] body ds)] loc0
224
225
cvtd (FunD nm cls)   	    = FunMonoBind (vName nm) False (map cvtclause cls) loc0
cvtd (Meta.ValD p body ds)	    = PatMonoBind (cvtp p) (GRHSs (cvtguard body) 
226
227
228
229
230
							  (cvtdecs ds) 
							  void) loc0
cvtd x = panic "Illegal kind of declaration in where clause" 


231
cvtclause :: Meta.Clause -> Hs.Match RdrName
232
cvtclause (Clause ps body wheres)
233
    = Hs.Match (map cvtp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)
234
235
236



237
238
239
240
241
cvtdd :: Range -> ArithSeqInfo RdrName
cvtdd (FromR x) 	      = (From (cvt x))
cvtdd (FromThenR x y)     = (FromThen (cvt x) (cvt y))
cvtdd (FromToR x y)	      = (FromTo (cvt x) (cvt y))
cvtdd (FromThenToR x y z) = (FromThenTo (cvt x) (cvt y) (cvt z))
242
243


244
cvtstmts :: [Meta.Stmt] -> [Hs.Stmt RdrName]
245
246
247
cvtstmts []		       = [] -- this is probably an error as every [stmt] should end with ResultStmt
cvtstmts [NoBindS e]           = [ResultStmt (cvt e) loc0]      -- when its the last element use ResultStmt
cvtstmts (NoBindS e : ss)      = ExprStmt (cvt e) void loc0     : cvtstmts ss
248
249
cvtstmts (Meta.BindS p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss
cvtstmts (Meta.LetS ds : ss)   = LetStmt (cvtdecs ds)	    : cvtstmts ss
250
cvtstmts (Meta.ParS dss : ss)  = ParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss
251

252
cvtm :: Meta.Match -> Hs.Match RdrName
253
254
cvtm (Meta.Match p body wheres)
    = Hs.Match [cvtp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)
255
                             
256
257
258
cvtguard :: Meta.Body -> [GRHS RdrName]
cvtguard (GuardedB pairs) = map cvtpair pairs
cvtguard (NormalB e) 	 = [GRHS [  ResultStmt (cvt e) loc0 ] loc0]
259
260

cvtpair :: (Meta.Exp,Meta.Exp) -> GRHS RdrName
261
cvtpair (x,y) = GRHS [Hs.BindStmt truePat (cvt x) loc0,
262
263
264
		      ResultStmt (cvt y) loc0] loc0

cvtOverLit :: Lit -> HsOverLit
265
266
cvtOverLit (IntegerL i)  = mkHsIntegral i
cvtOverLit (RationalL r) = mkHsFractional r
267
-- An Integer is like an an (overloaded) '3' in a Haskell source program
268
-- Similarly 3.5 for fractionals
269
270

cvtLit :: Lit -> HsLit
271
272
273
274
275
cvtLit (IntPrimL i)    = HsIntPrim i
cvtLit (FloatPrimL f)  = HsFloatPrim f
cvtLit (DoublePrimL f) = HsDoublePrim f
cvtLit (CharL c)       = HsChar (ord c)
cvtLit (StringL s)     = HsString (mkFastString s)
276
277

cvtp :: Meta.Pat -> Hs.Pat RdrName
278
cvtp (Meta.LitP l)
279
280
281
  | overloadedLit l = NPatIn (cvtOverLit l) Nothing	-- Not right for negative
							-- patterns; need to think
							-- about that!
282
  | otherwise	    = Hs.LitPat (cvtLit l)
283
284
285
286
287
288
289
290
cvtp (Meta.VarP s)     = Hs.VarPat(vName s)
cvtp (TupP [p])   = cvtp p
cvtp (TupP ps)    = TuplePat (map cvtp ps) Boxed
cvtp (ConP s ps)  = ConPatIn (cName s) (PrefixCon (map cvtp ps))
cvtp (TildeP p)   = LazyPat (cvtp p)
cvtp (Meta.AsP s p) = AsPat (vName s) (cvtp p)
cvtp Meta.WildP   = WildPat void
cvtp (RecP c fs)  = ConPatIn (cName c) $ Hs.RecCon (map (\(s,p) -> (vName s,cvtp p)) fs)
291
cvtp (ListP ps)   = ListPat (map cvtp ps) void
292
293
294
295
296
297
298

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

cvt_tvs :: [String] -> [HsTyVarBndr RdrName]
cvt_tvs tvs = map (UserTyVar . tName) tvs

299
cvt_context :: Cxt -> HsContext RdrName 
300
301
cvt_context tys = map cvt_pred tys

302
cvt_pred :: Meta.Type -> HsPred RdrName
303
cvt_pred ty = case split_ty_app ty of
304
	   	(ConT tc, tys) -> HsClassP (tconName tc) (map cvtType tys)
305
		other -> pprPanic "Malformed predicate" (ppr ty)
306

307
cvtType :: Meta.Type -> HsType RdrName
308
cvtType ty = trans (root ty [])
309
  where root (AppT a b) zs = root a (cvtType b : zs)
310
311
        root t zs 	   = (t,zs)

312
        trans (TupleT n,args)
313
            | length args == n = HsTupleTy Boxed args
314
315
316
317
            | n == 0 = foldl HsAppTy (HsTyVar (tconName "()")) args
            | otherwise = foldl HsAppTy (HsTyVar (tconName ("(" ++ replicate (n-1) ',' ++ ")"))) args
        trans (ArrowT,   [x,y]) = HsFunTy x y
        trans (ListT,    [x])   = HsListTy x
318

319
320
	trans (VarT nm, args)	    = foldl HsAppTy (HsTyVar (tName nm)) args
        trans (ConT tc, args)       = foldl HsAppTy (HsTyVar (tconName tc)) args
321

322
323
	trans (ForallT tvs cxt ty, []) = mkExplicitHsForAllTy 
						(cvt_tvs tvs) (cvt_context cxt) (cvtType ty)
324

325
split_ty_app :: Meta.Type -> (Meta.Type, [Meta.Type])
326
327
split_ty_app ty = go ty []
  where
328
    go (AppT f a) as = go f (a:as)
329
330
331
332
    go f as 	     = (f,as)

-----------------------------------------------------------
sigP :: Dec -> Bool
333
sigP (Meta.SigD _ _) = True
334
335
336
337
338
339
340
341
342
343
344
sigP other	 = False


-----------------------------------------------------------
-- some useful things

truePat  = ConPatIn (cName "True") (PrefixCon [])
falsePat = ConPatIn (cName "False") (PrefixCon [])

overloadedLit :: Lit -> Bool
-- True for literals that Haskell treats as overloaded
345
346
347
overloadedLit (IntegerL  l) = True
overloadedLit (RationalL l) = True
overloadedLit l	            = False
348
349
350
351
352
353
354
355
356
357
358

void :: Type.Type
void = placeHolderType

loc0 :: SrcLoc
loc0 = generatedSrcLoc

-- variable names
vName :: String -> RdrName
vName = mkName varName

359
-- Constructor function names; this is Haskell source, hence srcDataName
360
cName :: String -> RdrName
361
cName = mkName srcDataName
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396

-- Type variable names
tName :: String -> RdrName
tName = mkName tvName

-- Type Constructor names
tconName = mkName tcName

mkName :: NameSpace -> String -> RdrName
-- Parse the string to see if it has a "." or ":" in it
-- so we know whether to generate a qualified or original 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

mkName ns str
  = split [] (reverse str)
  where
    split occ [] = mkRdrUnqual (mk_occ occ)
    split occ (c:d:rev) 	-- 'd' is the last char before the separator
	|  is_sep c 		-- E.g.		Fo.x	d='o'
	&& isAlphaNum d		--		Fo.+:	d='+' perhaps
	= mk_qual (reverse (d:rev)) c occ
    split occ (c:rev) = split (c:occ) rev

    mk_qual mod '.' occ = mkRdrQual (mk_mod mod) (mk_occ occ)
    mk_qual mod ':' occ = mkOrig    (mk_mod mod) (mk_occ occ)

    mk_occ occ = mkOccFS ns (mkFastString occ)
    mk_mod mod = mkModuleName mod

    is_sep '.' 	 = True
    is_sep ':' 	 = True
    is_sep other = False
\end{code}
397