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