ParserCore.y 12.4 KB
Newer Older
sof's avatar
sof committed
1
{
2
{-# OPTIONS -w #-}
3
4
5
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
6
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
7
8
-- for details

sof's avatar
sof committed
9
10
module ParserCore ( parseCore ) where

11
import IfaceSyn
krc's avatar
krc committed
12
import ForeignCall
sof's avatar
sof committed
13
14
15
16
import RdrHsSyn
import HsSyn
import RdrName
import OccName
17
18
19
20
import Type ( Kind,
              liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
              argTypeKindTyCon, ubxTupleKindTyCon, mkArrowKind, mkTyConApp
            )
21
import Name( Name, nameOccName, nameModule, mkExternalName )
sof's avatar
sof committed
22
23
24
25
26
import Module
import ParserCoreUtils
import LexCore
import Literal
import SrcLoc
27
28
29
import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, 
		floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
import TyCon ( TyCon, tyConName )
30
import FastString
31
import Outputable
32
import Char
33
import Unique
sof's avatar
sof committed
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

#include "../HsVersions.h"

}

%name parseCore
%tokentype { Token }

%token
 '%module'	{ TKmodule }
 '%data'	{ TKdata }
 '%newtype'	{ TKnewtype }
 '%forall'	{ TKforall }
 '%rec'		{ TKrec }
 '%let'		{ TKlet }
 '%in'		{ TKin }
 '%case'	{ TKcase }
 '%of'		{ TKof }
52
 '%cast'	{ TKcast }
sof's avatar
sof committed
53
54
 '%note'	{ TKnote }
 '%external'	{ TKexternal }
55
 '%local'	{ TKlocal }
sof's avatar
sof committed
56
57
58
59
60
61
62
 '%_'		{ TKwild }
 '('		{ TKoparen }
 ')'		{ TKcparen }
 '{'		{ TKobrace }
 '}'		{ TKcbrace }
 '#' 		{ TKhash}
 '='		{ TKeq }
63
 ':'		{ TKcolon }
sof's avatar
sof committed
64
 '::'		{ TKcoloncolon }
65
 ':=:'		{ TKcoloneqcolon }
sof's avatar
sof committed
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
 '*'		{ TKstar }
 '->'		{ TKrarrow }
 '\\'		{ TKlambda}
 '@'		{ TKat }
 '.'		{ TKdot }
 '?'		{ TKquestion}
 ';'            { TKsemicolon }
 NAME		{ TKname $$ }
 CNAME 		{ TKcname $$ }
 INTEGER	{ TKinteger $$ }
 RATIONAL	{ TKrational $$ }
 STRING		{ TKstring $$ }
 CHAR		{ TKchar $$ }

%monad { P } { thenP } { returnP }
%lexer { lexer } { TKEOF }

%%

85
module	:: { HsExtCore RdrName }
86
87
	-- : '%module' modid tdefs vdefgs	{ HsExtCore $2 $3 $4 }
	: '%module' modid tdefs vdefgs	{ HsExtCore $2 [] [] }
88

89
90
91
92
93
94
95
96

-------------------------------------------------------------
--     Names: the trickiest bit in here

-- A name of the form A.B.C could be:
--   module A.B.C
--   dcon C in module A.B
--   tcon C in module A.B
97
modid	:: { Module }
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
	: NAME ':' mparts		{ undefined }

q_dc_name :: { Name }
	  : NAME ':' mparts		{ undefined }

q_tc_name :: { Name }
 	  : NAME ':' mparts		{ undefined }

q_var_occ :: { Name }
          : NAME ':' vparts             { undefined }

mparts	:: { [String] }
	: CNAME				{ [$1] }
	| CNAME '.' mparts		{ $1:$3 }

vparts  :: { [String] }
        : var_occ                       { [$1] }
        | CNAME '.' vparts              { $1:$3 }
116
117
118

-------------------------------------------------------------
--     Type and newtype declarations are in HsSyn syntax
sof's avatar
sof committed
119

120
tdefs	:: { [TyClDecl RdrName] }
sof's avatar
sof committed
121
	: {- empty -}	{[]}
122
	| tdef tdefs	{$1:$2}
sof's avatar
sof committed
123

124
tdef	:: { TyClDecl RdrName }
125
	: '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
126
127
128
129
130
                { mkTyData DataType ( noLoc []
				    , noLoc (ifaceExtRdrName $2)
				    , map toHsTvBndr $3
				    , Nothing
				    ) Nothing $6 Nothing }
131
	| '%newtype' q_tc_name tv_bndrs trep ';'
132
		{ let tc_rdr = ifaceExtRdrName $2 in
133
134
135
136
137
                  mkTyData NewType ( noLoc []
				   , noLoc tc_rdr
				   , map toHsTvBndr $3
				   , Nothing
				   ) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
138
139
140

-- For a newtype we have to invent a fake data constructor name
-- It doesn't matter what it is, because it won't be used
141
trep    :: { OccName -> [LConDecl RdrName] }
142
143
        : {- empty -}   { (\ tc_occ -> []) }
        | '=' ty        { (\ tc_occ -> let { dc_name  = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
144
			                     con_info = PrefixCon [toHsType $2] }
145
			                in [noLoc $ ConDecl (noLoc dc_name) Explicit []
146
					   (noLoc []) con_info ResTyH98 Nothing]) }
sof's avatar
sof committed
147

148
149
cons	:: { [LConDecl RdrName] }
	: {- empty -}	{ [] } -- 20060420 Empty data types allowed. jds
150
        | con           { [$1] }
151
	| con ';' cons	{ $1:$3 }
sof's avatar
sof committed
152

153
con	:: { LConDecl RdrName }
154
	: d_pat_occ attv_bndrs hs_atys 
155
		{ noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98 Nothing }
156
        | d_pat_occ '::' ty
157
                -- XXX - audreyt - $3 needs to be split into argument and return types!
158
159
160
161
162
                -- also not sure whether the [] below (quantified vars) appears.
                -- also the "PrefixCon []" is wrong.
                -- also we want to munge $3 somehow.
                -- extractWhatEver to unpack ty into the parts to ConDecl
                -- XXX - define it somewhere in RdrHsSyn
163
		{ noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) Nothing }
sof's avatar
sof committed
164

165
attv_bndrs :: { [LHsTyVarBndr RdrName] }
166
167
	: {- empty -} 	         { [] }
	| '@' tv_bndr attv_bndrs {  toHsTvBndr $2 : $3 }
sof's avatar
sof committed
168

169
hs_atys :: { [LHsType RdrName] }
170
         : atys               { map toHsType $1 }
sof's avatar
sof committed
171

172

173
174
175
---------------------------------------
--                 Types
---------------------------------------
sof's avatar
sof committed
176

177
178
179
atys	:: { [IfaceType] }
	: {- empty -}   { [] }
	| aty atys      { $1:$2 }
sof's avatar
sof committed
180

181
aty	:: { IfaceType }
182
	: fs_var_occ { IfaceTyVar $1 }
183
184
	| q_tc_name  { IfaceTyConApp (IfaceTc $1) [] }
	| '(' ty ')' { $2 }
sof's avatar
sof committed
185

186
bty	:: { IfaceType }
187
188
	: fs_var_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 }
        | q_var_occ atys  { undefined }
189
        | q_tc_name atys  { IfaceTyConApp (IfaceTc $1) $2 }
190
        | '(' ty ')' { $2 }
sof's avatar
sof committed
191

192
193
194
195
ty	:: { IfaceType }
	: bty	                     { $1 }
	| bty '->' ty                { IfaceFunTy $1 $3 }
	| '%forall' tv_bndrs '.' ty  { foldr IfaceForAllTy $4 $2 }
sof's avatar
sof committed
196

197
198
----------------------------------------------
--        Bindings are in Iface syntax
sof's avatar
sof committed
199

200
201
202
vdefgs	:: { [IfaceBinding] }
	: {- empty -}	        { [] }
	| let_bind ';' vdefgs	{ $1 : $3 }
sof's avatar
sof committed
203

204
let_bind :: { IfaceBinding }
205
	: '%rec' '{' vdefs1 '}' { IfaceRec $3 } -- Can be empty. Do we care?
206
207
	|  vdef                 { let (b,r) = $1
				  in IfaceNonRec b r }
sof's avatar
sof committed
208

209
vdefs1	:: { [(IfaceLetBndr, IfaceExpr)] }
210
	: vdef  	        { [$1] }
211
	| vdef ';' vdefs1       { $1:$3 }
sof's avatar
sof committed
212

213
214
vdef	:: { (IfaceLetBndr, IfaceExpr) }
	: fs_var_occ '::' ty '=' exp { (IfLetBndr $1 $3 NoInfo, $5) }
215
216
        | '%local' vdef              { $2 }

217
218
219
220
  -- NB: qd_occ includes data constructors, because
  --     we allow data-constructor wrappers at top level
  -- But we discard the module name, because it must be the
  -- same as the module being compiled, and Iface syntax only
221
  -- has OccNames in binding positions. Ah, but it has Names now!
sof's avatar
sof committed
222

223
224
225
226
227
---------------------------------------
--  Binders
bndr	:: { IfaceBndr }
        : '@' tv_bndr 	{ IfaceTvBndr $2 }
	| id_bndr	{ IfaceIdBndr $1 }
sof's avatar
sof committed
228

229
230
231
bndrs 	:: { [IfaceBndr] }
	: bndr		{ [$1] }
	| bndr bndrs	{ $1:$2 }
sof's avatar
sof committed
232

233
id_bndr	:: { IfaceIdBndr }
234
	: '(' fs_var_occ '::' ty ')'	{ ($2,$4) }
235
236

tv_bndr	:: { IfaceTvBndr }
237
238
	:  fs_var_occ                    { ($1, ifaceLiftedTypeKind) }
	|  '(' fs_var_occ '::' akind ')' { ($2, $4) }
239
240
241
242
243
244

tv_bndrs 	:: { [IfaceTvBndr] }
	: {- empty -}	{ [] }
	| tv_bndr tv_bndrs	{ $1:$2 }

akind	:: { IfaceKind }
245
246
247
	: '*' 		   { ifaceLiftedTypeKind }	
	| '#'		   { ifaceUnliftedTypeKind }
	| '?'		   { ifaceOpenTypeKind }
248
        | '(' kind ')'	   { $2 }
sof's avatar
sof committed
249

250
251
kind 	:: { IfaceKind }
	: akind 	   { $1 }
252
	| akind '->' kind  { ifaceArrow $1 $3 }
253
        | ty ':=:' ty      { ifaceEq $1 $3 }
sof's avatar
sof committed
254

255
256
-----------------------------------------
--             Expressions
sof's avatar
sof committed
257

258
aexp    :: { IfaceExpr }
259
260
261
	: fs_var_occ    { IfaceLcl $1 }
        | q_var_occ    	{ IfaceExt $1 }
	| q_dc_name	{ IfaceExt $1 }
262
	| lit		{ IfaceLit $1 }
sof's avatar
sof committed
263
264
	| '(' exp ')' 	{ $2 }

265
266
267
fexp	:: { IfaceExpr }
	: fexp aexp	{ IfaceApp $1 $2 }
	| fexp '@' aty	{ IfaceApp $1 (IfaceType $3) }
sof's avatar
sof committed
268
269
	| aexp		{ $1 }

270
271
272
273
exp	:: { IfaceExpr }
	: fexp		              { $1 }
	| '\\' bndrs '->' exp 	      { foldr IfaceLam $4 $2 }
	| '%let' let_bind '%in' exp   { IfaceLet $2 $4 }
274
275
276
-- gaw 2004
	| '%case' '(' ty ')' aexp '%of' id_bndr
	  '{' alts1 '}'		      { IfaceCase $5 (fst $7) $3 $9 }
277
        | '%cast' aexp aty { IfaceCast $2 $3 }
sof's avatar
sof committed
278
279
	| '%note' STRING exp 	   
	    { case $2 of
280
281
	       --"SCC"      -> IfaceNote (IfaceSCC "scc") $3
	       "InlineMe"   -> IfaceNote IfaceInlineMe $3
sof's avatar
sof committed
282
            }
283
284
285
286
287
288
        | '%external' STRING aty   { IfaceFCall (ForeignCall.CCall 
                                                    (CCallSpec (StaticTarget (mkFastString $2)) 
                                                               CCallConv (PlaySafe False))) 
                                                 $3 }

alts1	:: { [IfaceAlt] }
sof's avatar
sof committed
289
290
291
	: alt		{ [$1] }
	| alt ';' alts1	{ $1:$3 }

292
alt	:: { IfaceAlt }
293
294
	: q_dc_name bndrs '->' exp 
		{ (IfaceDataAlt $1, map ifaceBndrName $2, $4) } 
295
296
297
                       -- The external syntax currently includes the types of the
		       -- the args, but they aren't needed internally
                       -- Nor is the module qualifier
298
299
	| q_dc_name '->' exp 
		{ (IfaceDataAlt $1, [], $3) } 
sof's avatar
sof committed
300
	| lit '->' exp
301
		{ (IfaceLitAlt $1, [], $3) }
sof's avatar
sof committed
302
	| '%_' '->' exp
303
		{ (IfaceDefault, [], $3) }
sof's avatar
sof committed
304
305

lit	:: { Literal }
306
	: '(' INTEGER '::' aty ')'	{ convIntLit $2 $4 }
307
	| '(' RATIONAL '::' aty ')'	{ convRatLit $2 $4 }
308
	| '(' CHAR '::' aty ')'		{ MachChar $2 }
309
	| '(' STRING '::' aty ')'	{ MachStr (mkFastString $2) }
sof's avatar
sof committed
310

311
312
fs_var_occ	:: { FastString }
		: NAME	{ mkFastString $1 }
sof's avatar
sof committed
313

314
315
var_occ	:: { String }
	: NAME	{ $1 }
316

sof's avatar
sof committed
317

318
319
-- Data constructor in a pattern or data type declaration; use the dataName, 
-- because that's what we expect in Core case patterns
320
d_pat_occ :: { OccName }
321
        : CNAME      { mkOccName dataName $1 }
sof's avatar
sof committed
322
323

{
324

325
326
ifaceKind kc = IfaceTyConApp kc []

327
328
ifaceBndrName (IfaceIdBndr (n,_)) = n
ifaceBndrName (IfaceTvBndr (n,_)) = n
329

330
331
332
333
convIntLit :: Integer -> IfaceType -> Literal
convIntLit i (IfaceTyConApp tc [])
  | tc `eqTc` intPrimTyCon  = MachInt  i  
  | tc `eqTc` wordPrimTyCon = MachWord i
334
  | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i))
335
336
337
  | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr
convIntLit i aty
  = pprPanic "Unknown integer literal type" (ppr aty)
338

339
340
341
342
343
344
345
346
convRatLit :: Rational -> IfaceType -> Literal
convRatLit r (IfaceTyConApp tc [])
  | tc `eqTc` floatPrimTyCon  = MachFloat  r
  | tc `eqTc` doublePrimTyCon = MachDouble r
convRatLit i aty
  = pprPanic "Unknown rational literal type" (ppr aty)

eqTc :: IfaceTyCon -> TyCon -> Bool   -- Ugh!
347
eqTc (IfaceTc name) tycon = name == tyConName tycon
348
349
350
351
352
353

-- Tiresomely, we have to generate both HsTypes (in type/class decls) 
-- and IfaceTypes (in Core expressions).  So we parse them as IfaceTypes,
-- and convert to HsTypes here.  But the IfaceTypes we can see here
-- are very limited (see the productions for 'ty', so the translation
-- isn't hard
354
toHsType :: IfaceType -> LHsType RdrName
355
toHsType (IfaceTyVar v)        		 = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOccFS v))
356
357
358
toHsType (IfaceAppTy t1 t2)    		 = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
toHsType (IfaceFunTy t1 t2)    		 = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) 
359
360
toHsType (IfaceForAllTy tv t)            = add_forall (toHsTvBndr tv) (toHsType t)

361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
-- We also need to convert IfaceKinds to Kinds (now that they are different).
-- Only a limited form of kind will be encountered... hopefully
toKind :: IfaceKind -> Kind
toKind (IfaceFunTy ifK1 ifK2)  = mkArrowKind (toKind ifK1) (toKind ifK2)
toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) []
toKind other                   = pprPanic "toKind" (ppr other)

toKindTc :: IfaceTyCon -> TyCon
toKindTc IfaceLiftedTypeKindTc   = liftedTypeKindTyCon
toKindTc IfaceOpenTypeKindTc     = openTypeKindTyCon
toKindTc IfaceUnliftedTypeKindTc = unliftedTypeKindTyCon
toKindTc IfaceUbxTupleKindTc     = ubxTupleKindTyCon
toKindTc IfaceArgTypeKindTc      = argTypeKindTyCon
toKindTc other                   = pprPanic "toKindTc" (ppr other)

ifaceTcType ifTc = IfaceTyConApp ifTc []

ifaceLiftedTypeKind   = ifaceTcType IfaceLiftedTypeKindTc
ifaceOpenTypeKind     = ifaceTcType IfaceOpenTypeKindTc
ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc

ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2

384
385
ifaceEq ifT1 ifT2 = IfacePredTy (IfaceEqPred ifT1 ifT2)

386
toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
387
toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toKind k)
388

389
390
ifaceExtRdrName :: Name -> RdrName
ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
391
392
ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)

393
394
395
396
add_forall tv (L _ (HsForAllTy exp tvs cxt t))
  = noLoc $ HsForAllTy exp (tv:tvs) cxt t
add_forall tv t
  = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
397
  
sof's avatar
sof committed
398
399
400
happyError :: P a 
happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
}
401