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