b24ec2e9d7cb810fcf997e18865881b06efc34fc
[ghc-hetmet.git] / compiler / parser / ParserCore.y
1 {
2 module ParserCore ( parseCore ) where
3
4 import IfaceSyn
5 import ForeignCall
6 import RdrHsSyn
7 import HsSyn
8 import RdrName
9 import OccName
10 import Type ( Kind,
11               liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
12               argTypeKindTyCon, ubxTupleKindTyCon, mkArrowKind, mkTyConApp
13             )
14 import Name( nameOccName, nameModule )
15 import Module
16 import PackageConfig    ( mainPackageId )
17 import ParserCoreUtils
18 import LexCore
19 import Literal
20 import SrcLoc
21 import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, 
22                 floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
23 import TyCon ( TyCon, tyConName )
24 import FastString
25 import Outputable
26 import Char
27
28 #include "../HsVersions.h"
29
30 }
31
32 %name parseCore
33 %tokentype { Token }
34
35 %token
36  '%module'      { TKmodule }
37  '%data'        { TKdata }
38  '%newtype'     { TKnewtype }
39  '%forall'      { TKforall }
40  '%rec'         { TKrec }
41  '%let'         { TKlet }
42  '%in'          { TKin }
43  '%case'        { TKcase }
44  '%of'          { TKof }
45  '%cast'        { TKcast }
46  '%note'        { TKnote }
47  '%external'    { TKexternal }
48  '%_'           { TKwild }
49  '('            { TKoparen }
50  ')'            { TKcparen }
51  '{'            { TKobrace }
52  '}'            { TKcbrace }
53  '#'            { TKhash}
54  '='            { TKeq }
55  '::'           { TKcoloncolon }
56  '*'            { TKstar }
57  '->'           { TKrarrow }
58  '\\'           { TKlambda}
59  '@'            { TKat }
60  '.'            { TKdot }
61  '?'            { TKquestion}
62  ';'            { TKsemicolon }
63  NAME           { TKname $$ }
64  CNAME          { TKcname $$ }
65  INTEGER        { TKinteger $$ }
66  RATIONAL       { TKrational $$ }
67  STRING         { TKstring $$ }
68  CHAR           { TKchar $$ }
69
70 %monad { P } { thenP } { returnP }
71 %lexer { lexer } { TKEOF }
72
73 %%
74
75 module  :: { HsExtCore RdrName }
76          : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 }
77
78 modid   :: { Module }
79         : CNAME                  { mkModule mainPackageId  -- ToDo: wrong
80                                         (mkModuleNameFS (mkFastString $1)) }
81
82 -------------------------------------------------------------
83 --     Type and newtype declarations are in HsSyn syntax
84
85 tdefs   :: { [TyClDecl RdrName] }
86         : {- empty -}   {[]}
87         | tdef ';' tdefs        {$1:$3}
88
89 tdef    :: { TyClDecl RdrName }
90         : '%data' q_tc_name tv_bndrs '=' '{' cons '}'
91                 { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) Nothing $6 Nothing }
92         | '%newtype' q_tc_name tv_bndrs trep 
93                 { let tc_rdr = ifaceExtRdrName $2 in
94                   mkTyData NewType (noLoc [], noLoc tc_rdr, map toHsTvBndr $3) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
95
96 -- For a newtype we have to invent a fake data constructor name
97 -- It doesn't matter what it is, because it won't be used
98 trep    :: { OccName -> [LConDecl RdrName] }
99         : {- empty -}   { (\ tc_occ -> []) }
100         | '=' ty        { (\ tc_occ -> let { dc_name  = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
101                                              con_info = PrefixCon [toHsType $2] }
102                                         in [noLoc $ ConDecl (noLoc dc_name) Explicit []
103                                            (noLoc []) con_info ResTyH98]) }
104
105 cons    :: { [LConDecl RdrName] }
106         : {- empty -}   { [] } -- 20060420 Empty data types allowed. jds
107         | con ';' cons  { $1:$3 }
108
109 con     :: { LConDecl RdrName }
110         : d_pat_occ attv_bndrs hs_atys 
111                 { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98}
112         | d_pat_occ '::' ty
113                 -- XXX - audreyt - $3 needs to be split into argument and return types!
114                 -- also not sure whether the [] below (quantified vars) appears.
115                 -- also the "PrefixCon []" is wrong.
116                 -- also we want to munge $3 somehow.
117                 -- extractWhatEver to unpack ty into the parts to ConDecl
118                 -- XXX - define it somewhere in RdrHsSyn
119                 { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) }
120
121 attv_bndrs :: { [LHsTyVarBndr RdrName] }
122         : {- empty -}            { [] }
123         | '@' tv_bndr attv_bndrs {  toHsTvBndr $2 : $3 }
124
125 hs_atys :: { [LHsType RdrName] }
126          : atys               { map toHsType $1 }
127
128
129 ---------------------------------------
130 --                 Types
131 ---------------------------------------
132
133 atys    :: { [IfaceType] }
134         : {- empty -}   { [] }
135         | aty atys      { $1:$2 }
136
137 aty     :: { IfaceType }
138         : tv_occ    { IfaceTyVar $1 }
139         | q_tc_name  { IfaceTyConApp (IfaceTc $1) [] }
140         | '(' ty ')' { $2 }
141
142 bty     :: { IfaceType }
143         : tv_occ atys    { foldl IfaceAppTy (IfaceTyVar $1) $2 }
144         | q_tc_name atys  { IfaceTyConApp (IfaceTc $1) $2 }
145         | '(' ty ')' { $2 }
146
147 ty      :: { IfaceType }
148         : bty                        { $1 }
149         | bty '->' ty                { IfaceFunTy $1 $3 }
150         | '%forall' tv_bndrs '.' ty  { foldr IfaceForAllTy $4 $2 }
151
152 ----------------------------------------------
153 --        Bindings are in Iface syntax
154
155 vdefgs  :: { [IfaceBinding] }
156         : {- empty -}           { [] }
157         | let_bind ';' vdefgs   { $1 : $3 }
158
159 let_bind :: { IfaceBinding }
160         : '%rec' '{' vdefs1 '}' { IfaceRec $3 }
161         |  vdef                 { let (b,r) = $1
162                                   in IfaceNonRec b r }
163
164 vdefs1  :: { [(IfaceIdBndr, IfaceExpr)] }
165         : vdef                  { [$1] }
166         | vdef ';' vdefs1       { $1:$3 }
167
168 vdef    :: { (IfaceIdBndr, IfaceExpr) }
169         : qd_occ '::' ty '=' exp { (($1, $3), $5) }
170   -- NB: qd_occ includes data constructors, because
171   --     we allow data-constructor wrappers at top level
172   -- But we discard the module name, because it must be the
173   -- same as the module being compiled, and Iface syntax only
174   -- has OccNames in binding positions
175
176 qd_occ :: { FastString }
177         : var_occ { $1 }
178         | d_occ   { $1 }
179
180 ---------------------------------------
181 --  Binders
182 bndr    :: { IfaceBndr }
183         : '@' tv_bndr   { IfaceTvBndr $2 }
184         | id_bndr       { IfaceIdBndr $1 }
185
186 bndrs   :: { [IfaceBndr] }
187         : bndr          { [$1] }
188         | bndr bndrs    { $1:$2 }
189
190 id_bndr :: { IfaceIdBndr }
191         : '(' var_occ '::' ty ')'       { ($2,$4) }
192
193 id_bndrs :: { [IfaceIdBndr] }
194         : {-empty -}            { [] }
195         | id_bndr id_bndrs      { $1:$2 }
196
197 tv_bndr :: { IfaceTvBndr }
198         :  tv_occ                    { ($1, ifaceLiftedTypeKind) }
199         |  '(' tv_occ '::' akind ')' { ($2, $4) }
200
201 tv_bndrs        :: { [IfaceTvBndr] }
202         : {- empty -}   { [] }
203         | tv_bndr tv_bndrs      { $1:$2 }
204
205 akind   :: { IfaceKind }
206         : '*'              { ifaceLiftedTypeKind }      
207         | '#'              { ifaceUnliftedTypeKind }
208         | '?'              { ifaceOpenTypeKind }
209         | '(' kind ')'     { $2 }
210
211 kind    :: { IfaceKind }
212         : akind            { $1 }
213         | akind '->' kind  { ifaceArrow $1 $3 }
214
215 -----------------------------------------
216 --             Expressions
217
218 aexp    :: { IfaceExpr }
219         : var_occ                { IfaceLcl $1 }
220         | modid '.' qd_occ       { IfaceExt (ExtPkg $1 (mkVarOccFS $3)) }
221         | lit           { IfaceLit $1 }
222         | '(' exp ')'   { $2 }
223
224 fexp    :: { IfaceExpr }
225         : fexp aexp     { IfaceApp $1 $2 }
226         | fexp '@' aty  { IfaceApp $1 (IfaceType $3) }
227         | aexp          { $1 }
228
229 exp     :: { IfaceExpr }
230         : fexp                        { $1 }
231         | '\\' bndrs '->' exp         { foldr IfaceLam $4 $2 }
232         | '%let' let_bind '%in' exp   { IfaceLet $2 $4 }
233 -- gaw 2004
234         | '%case' '(' ty ')' aexp '%of' id_bndr
235           '{' alts1 '}'               { IfaceCase $5 (fst $7) $3 $9 }
236         | '%cast' exp aty { IfaceCast $2 $3 }
237         | '%note' STRING exp       
238             { case $2 of
239                --"SCC"      -> IfaceNote (IfaceSCC "scc") $3
240                "InlineMe"   -> IfaceNote IfaceInlineMe $3
241             }
242         | '%external' STRING aty   { IfaceFCall (ForeignCall.CCall 
243                                                     (CCallSpec (StaticTarget (mkFastString $2)) 
244                                                                CCallConv (PlaySafe False))) 
245                                                  $3 }
246
247 alts1   :: { [IfaceAlt] }
248         : alt           { [$1] }
249         | alt ';' alts1 { $1:$3 }
250
251 alt     :: { IfaceAlt }
252         : modid '.' d_pat_occ bndrs '->' exp 
253                 { (IfaceDataAlt $3, map ifaceBndrName $4, $6) } 
254                        -- The external syntax currently includes the types of the
255                        -- the args, but they aren't needed internally
256                        -- Nor is the module qualifier
257         | lit '->' exp
258                 { (IfaceLitAlt $1, [], $3) }
259         | '%_' '->' exp
260                 { (IfaceDefault, [], $3) }
261
262 lit     :: { Literal }
263         : '(' INTEGER '::' aty ')'      { convIntLit $2 $4 }
264         | '(' RATIONAL '::' aty ')'     { convRatLit $2 $4 }
265         | '(' CHAR '::' aty ')'         { MachChar $2 }
266         | '(' STRING '::' aty ')'       { MachStr (mkFastString $2) }
267
268 tv_occ  :: { FastString }
269         : NAME  { mkFastString $1 }
270
271 var_occ :: { FastString }
272         : NAME  { mkFastString $1 }
273
274
275 -- Type constructor
276 q_tc_name       :: { IfaceExtName }
277         : modid '.' CNAME       { ExtPkg $1 (mkOccName tcName $3) }
278
279 -- Data constructor in a pattern or data type declaration; use the dataName, 
280 -- because that's what we expect in Core case patterns
281 d_pat_occ :: { OccName }
282         : CNAME      { mkOccName dataName $1 }
283
284 -- Data constructor occurrence in an expression;
285 -- use the varName because that's the worker Id
286 d_occ :: { FastString }
287        : CNAME { mkFastString $1 }
288
289 {
290
291 ifaceKind kc = IfaceTyConApp kc []
292
293 ifaceBndrName (IfaceIdBndr (n,_)) = n
294 ifaceBndrName (IfaceTvBndr (n,_)) = n
295
296 convIntLit :: Integer -> IfaceType -> Literal
297 convIntLit i (IfaceTyConApp tc [])
298   | tc `eqTc` intPrimTyCon  = MachInt  i  
299   | tc `eqTc` wordPrimTyCon = MachWord i
300   | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i))
301   | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr
302 convIntLit i aty
303   = pprPanic "Unknown integer literal type" (ppr aty)
304
305 convRatLit :: Rational -> IfaceType -> Literal
306 convRatLit r (IfaceTyConApp tc [])
307   | tc `eqTc` floatPrimTyCon  = MachFloat  r
308   | tc `eqTc` doublePrimTyCon = MachDouble r
309 convRatLit i aty
310   = pprPanic "Unknown rational literal type" (ppr aty)
311
312 eqTc :: IfaceTyCon -> TyCon -> Bool   -- Ugh!
313 eqTc (IfaceTc (ExtPkg mod occ)) tycon
314   = mod == nameModule nm && occ == nameOccName nm
315   where
316     nm = tyConName tycon
317
318 -- Tiresomely, we have to generate both HsTypes (in type/class decls) 
319 -- and IfaceTypes (in Core expressions).  So we parse them as IfaceTypes,
320 -- and convert to HsTypes here.  But the IfaceTypes we can see here
321 -- are very limited (see the productions for 'ty', so the translation
322 -- isn't hard
323 toHsType :: IfaceType -> LHsType RdrName
324 toHsType (IfaceTyVar v)                  = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOcc v))
325 toHsType (IfaceAppTy t1 t2)              = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
326 toHsType (IfaceFunTy t1 t2)              = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
327 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) 
328 toHsType (IfaceForAllTy tv t)            = add_forall (toHsTvBndr tv) (toHsType t)
329
330 -- We also need to convert IfaceKinds to Kinds (now that they are different).
331 -- Only a limited form of kind will be encountered... hopefully
332 toKind :: IfaceKind -> Kind
333 toKind (IfaceFunTy ifK1 ifK2)  = mkArrowKind (toKind ifK1) (toKind ifK2)
334 toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) []
335 toKind other                   = pprPanic "toKind" (ppr other)
336
337 toKindTc :: IfaceTyCon -> TyCon
338 toKindTc IfaceLiftedTypeKindTc   = liftedTypeKindTyCon
339 toKindTc IfaceOpenTypeKindTc     = openTypeKindTyCon
340 toKindTc IfaceUnliftedTypeKindTc = unliftedTypeKindTyCon
341 toKindTc IfaceUbxTupleKindTc     = ubxTupleKindTyCon
342 toKindTc IfaceArgTypeKindTc      = argTypeKindTyCon
343 toKindTc other                   = pprPanic "toKindTc" (ppr other)
344
345 ifaceTcType ifTc = IfaceTyConApp ifTc []
346
347 ifaceLiftedTypeKind   = ifaceTcType IfaceLiftedTypeKindTc
348 ifaceOpenTypeKind     = ifaceTcType IfaceOpenTypeKindTc
349 ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc
350
351 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
352
353 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
354 toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) (toKind k)
355
356 ifaceExtRdrName :: IfaceExtName -> RdrName
357 ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ
358 ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
359
360 add_forall tv (L _ (HsForAllTy exp tvs cxt t))
361   = noLoc $ HsForAllTy exp (tv:tvs) cxt t
362 add_forall tv t
363   = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
364   
365 happyError :: P a 
366 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
367 }
368