Convert.lhs 12.7 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(..),
18
		Match(..), GRHSs(..), GRHS(..), HsPred(..),
chak's avatar
chak committed
19
		HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
20
21
22
23
24
25
26
27
28
		Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
		Pat(..), HsConDetails(..), HsOverLit, BangType(..),
		placeHolderType, HsType(..), HsTupCon(..),
		HsTyVarBndr(..), HsContext,
		mkSimpleMatch
	) 

import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig )
import Module   ( mkModuleName )
29
import RdrHsSyn	( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
30
31
32
33
34
35
import OccName
import SrcLoc	( SrcLoc, generatedSrcLoc )
import TyCon	( DataConDetails(..) )
import Type	( Type )
import BasicTypes( Boxity(..), RecFlag(Recursive), 
		   NewOrData(..), StrictnessMark(..) )
36
37
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
import HsDecls ( CImportSpec(..), ForeignImport(..), 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

50
51
52
cvt_top :: Meta.Dec -> Either (HsDecl RdrName) Message
cvt_top d@(Val _ _ _) = Left $ ValD (cvtd d)
cvt_top d@(Fun _ _)   = Left $ ValD (cvtd d)
53
 
54
cvt_top (TySyn tc tvs rhs)
55
  = Left $ TyClD (TySynonym (tconName tc) (cvt_tvs tvs) (cvtType rhs) loc0)
56

57
cvt_top (Data tc tvs constrs derivs)
58
59
60
61
  = Left $ TyClD (mkTyData DataType 
                           (noContext, tconName tc, cvt_tvs tvs)
                           (DataCons (map mk_con constrs))
                           (mk_derivs derivs) loc0)
62
63
  where
    mk_con (Constr c tys)
64
	= ConDecl (cName c) noExistentials noContext
65
66
67
68
69
70
71
72
		    (PrefixCon (map mk_arg tys)) loc0

    mk_arg ty = BangType NotMarkedStrict (cvtType ty)

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

cvt_top (Class ctxt cl tvs decs)
73
74
75
  = Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs)
                              noFunDeps
                              sigs (Just binds) loc0)
76
77
78
79
  where
    (binds,sigs) = cvtBindsAndSigs decs

cvt_top (Instance tys ty decs)
80
  = Left $ InstD (InstDecl inst_ty binds sigs Nothing loc0)
81
82
83
84
85
86
  where
    (binds, sigs) = cvtBindsAndSigs decs
    inst_ty = HsForAllTy Nothing 
			 (cvt_context tys) 
			 (HsPredTy (cvt_pred ty))

87
cvt_top (Proto nm typ) = Left $ SigD (Sig (vName nm) (cvtType typ) loc0)
88

89
cvt_top (Foreign (Import callconv safety from nm typ))
90
91
92
93
94
95
96
 = 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
97
98
99
100
101
102
                          CCall -> CCallConv
                          StdCall -> StdCallConv
          safety' = case safety of
                        Unsafe     -> PlayRisky
                        Safe       -> PlaySafe False
                        Threadsafe -> PlaySafe True
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
          parsed = parse_ccall_impent nm from

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` "._")
144

145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
noContext      = []
noExistentials = []
noFunDeps      = []

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

cvt (Var s) 	  = HsVar(vName s)
cvt (Con s) 	  = HsVar(cName s)
cvt (Lit l) 
  | overloadedLit l = HsOverLit (cvtOverLit l)
  | otherwise	    = HsLit (cvtLit l)

cvt (App x y)     = HsApp (cvt x) (cvt y)
cvt (Lam ps e)    = HsLam (mkSimpleMatch (map cvtp ps) (cvt e) void loc0)
161
cvt (Tup [e])	  = cvt e
162
163
164
165
166
167
168
169
cvt (Tup es)	  = ExplicitTuple(map cvt es) Boxed
cvt (Cond x y z)  = HsIf (cvt x) (cvt y) (cvt z) loc0
cvt (Let ds e)	  = HsLet (cvtdecs ds) (cvt e)
cvt (Case e ms)   = HsCase (cvt e) (map cvtm ms) loc0
cvt (Do ss)	  = HsDo DoExpr (cvtstmts ss) [] void loc0
cvt (Comp ss)     = HsDo ListComp (cvtstmts ss) [] void loc0
cvt (ArithSeq dd) = ArithSeqIn (cvtdd dd)
cvt (ListExp xs)  = ExplicitList void (map cvt xs)
170
cvt (Infix (Just x) s (Just y))
171
172
173
174
    = HsPar (OpApp (cvt x) (cvt s) undefined (cvt y))
cvt (Infix Nothing  s (Just y)) = SectionR (cvt s) (cvt y)
cvt (Infix (Just x) s Nothing ) = SectionL (cvt x) (cvt s)
cvt (Infix Nothing  s Nothing ) = cvt s	-- Can I indicate this is an infix thing?
175
cvt (SigExp e t)		= ExprWithTySig (cvt e) (cvtType t)
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197

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

cvtSig (Proto nm typ) = Sig (vName nm) (cvtType typ) loc0

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
cvtd (Val (Pvar s) body ds) = FunMonoBind (vName s) False 
198
					  [cvtclause (Clause [] body ds)] loc0
199
200
201
202
203
204
205
206
cvtd (Fun nm cls)   	    = FunMonoBind (vName nm) False (map cvtclause cls) loc0
cvtd (Val p body ds)	    = PatMonoBind (cvtp p) (GRHSs (cvtguard body) 
							  (cvtdecs ds) 
							  void) loc0
cvtd x = panic "Illegal kind of declaration in where clause" 


cvtclause :: Meta.Clause (Meta.Pat) (Meta.Exp) (Meta.Dec) -> Hs.Match RdrName
207
208
cvtclause (Clause ps body wheres)
    = Match (map cvtp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228



cvtdd :: Meta.DDt -> ArithSeqInfo RdrName
cvtdd (Meta.From x) 	      = (Hs.From (cvt x))
cvtdd (Meta.FromThen x y)     = (Hs.FromThen (cvt x) (cvt y))
cvtdd (Meta.FromTo x y)	      = (Hs.FromTo (cvt x) (cvt y))
cvtdd (Meta.FromThenTo x y z) = (Hs.FromThenTo (cvt x) (cvt y) (cvt z))


cvtstmts :: [Meta.Stm] -> [Hs.Stmt RdrName]
cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
cvtstmts [NoBindSt e]      = [ResultStmt (cvt e) loc0]      -- when its the last element use ResultStmt
cvtstmts (NoBindSt e : ss) = ExprStmt (cvt e) void loc0     : cvtstmts ss
cvtstmts (BindSt p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss
cvtstmts (LetSt ds : ss)   = LetStmt (cvtdecs ds)	    : cvtstmts ss
cvtstmts (ParSt dss : ss)  = ParStmt(map cvtstmts dss)      : cvtstmts ss


cvtm :: Meta.Mat -> Hs.Match RdrName
229
230
cvtm (Mat p body wheres)
    = Match [cvtp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)
231
232
233
234
235
236
237
238
239
240
                             
cvtguard :: Meta.Rhs -> [GRHS RdrName]
cvtguard (Guarded pairs) = map cvtpair pairs
cvtguard (Normal e) 	 = [GRHS [  ResultStmt (cvt e) loc0 ] loc0]

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

cvtOverLit :: Lit -> HsOverLit
241
cvtOverLit (Integer i)  = mkHsIntegral i
242
cvtOverLit (Rational r) = mkHsFractional r
243
-- An Integer is like an an (overloaded) '3' in a Haskell source program
244
-- Similarly 3.5 for fractionals
245
246

cvtLit :: Lit -> HsLit
247
248
cvtLit (Char c)	  = HsChar (ord c)
cvtLit (String s) = HsString (mkFastString s)
249
250
251
252
253
254
255
256

cvtp :: Meta.Pat -> Hs.Pat RdrName
cvtp (Plit l)
  | overloadedLit l = NPatIn (cvtOverLit l) Nothing	-- Not right for negative
							-- patterns; need to think
							-- about that!
  | otherwise	    = LitPat (cvtLit l)
cvtp (Pvar s)     = VarPat(vName s)
257
cvtp (Ptup [p])   = cvtp p
258
259
260
261
262
263
264
265
266
267
268
269
cvtp (Ptup ps)    = TuplePat (map cvtp ps) Boxed
cvtp (Pcon s ps)  = ConPatIn (cName s) (PrefixCon (map cvtp ps))
cvtp (Ptilde p)   = LazyPat (cvtp p)
cvtp (Paspat s p) = AsPat (vName s) (cvtp p)
cvtp Pwild        = WildPat void

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

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

270
cvt_context :: Cxt -> HsContext RdrName 
271
272
273
274
cvt_context tys = map cvt_pred tys

cvt_pred :: Typ -> HsPred RdrName
cvt_pred ty = case split_ty_app ty of
275
	   	(Tcon (TconName tc), tys) -> HsClassP (tconName tc) (map cvtType tys)
276
277
278
		other -> panic "Malformed predicate"

cvtType :: Meta.Typ -> HsType RdrName
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
cvtType ty = trans (root ty [])
  where root (Tapp a b) zs = root a (cvtType b : zs)
        root t zs 	   = (t,zs)

        trans (Tcon (Tuple n),args) | length args == n
				    = HsTupleTy (HsTupCon Boxed n) args
        trans (Tcon Arrow,   [x,y]) = HsFunTy x y
        trans (Tcon List,    [x])   = HsListTy x

	trans (Tvar nm, args)	    = foldl HsAppTy (HsTyVar (tName nm)) args
        trans (Tcon tc, args)       = foldl HsAppTy (HsTyVar (tc_name tc)) args

	tc_name (TconName nm) = tconName nm
	tc_name Arrow	      = tconName "->"
	tc_name List	      = tconName "[]"
	tc_name (Tuple 0)     = tconName "()"
   	tc_name (Tuple n)     = tconName ("(" ++ replicate (n-1) ',' ++ ")")
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

split_ty_app :: Typ -> (Typ, [Typ])
split_ty_app ty = go ty []
  where
    go (Tapp f a) as = go f (a:as)
    go f as 	     = (f,as)

-----------------------------------------------------------
sigP :: Dec -> Bool
sigP (Proto _ _) = True
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
317
318
319
overloadedLit (Integer  l) = True
overloadedLit (Rational l) = True
overloadedLit l	           = False
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368

void :: Type.Type
void = placeHolderType

loc0 :: SrcLoc
loc0 = generatedSrcLoc

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

-- Constructor function names
cName :: String -> RdrName
cName = mkName dataName

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