2 module ParserCore ( parseCore ) where
11 liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
12 argTypeKindTyCon, ubxTupleKindTyCon, mkArrowKind, mkTyConApp
14 import Name( nameOccName, nameModule )
16 import PackageConfig ( mainPackageId )
17 import ParserCoreUtils
21 import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon,
22 floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
23 import TyCon ( TyCon, tyConName )
28 #include "../HsVersions.h"
36 '%module' { TKmodule }
38 '%newtype' { TKnewtype }
39 '%forall' { TKforall }
47 '%external' { TKexternal }
65 INTEGER { TKinteger $$ }
66 RATIONAL { TKrational $$ }
67 STRING { TKstring $$ }
70 %monad { P } { thenP } { returnP }
71 %lexer { lexer } { TKEOF }
75 module :: { HsExtCore RdrName }
76 : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 }
79 : CNAME { mkModule mainPackageId -- ToDo: wrong
80 (mkModuleNameFS (mkFastString $1)) }
82 -------------------------------------------------------------
83 -- Type and newtype declarations are in HsSyn syntax
85 tdefs :: { [TyClDecl RdrName] }
87 | tdef ';' tdefs {$1:$3}
89 tdef :: { TyClDecl RdrName }
90 : '%data' q_tc_name tv_bndrs '=' '{' cons '}'
91 { mkTyData DataType ( noLoc []
92 , noLoc (ifaceExtRdrName $2)
95 ) Nothing $6 Nothing }
96 | '%newtype' q_tc_name tv_bndrs trep
97 { let tc_rdr = ifaceExtRdrName $2 in
98 mkTyData NewType ( noLoc []
102 ) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
104 -- For a newtype we have to invent a fake data constructor name
105 -- It doesn't matter what it is, because it won't be used
106 trep :: { OccName -> [LConDecl RdrName] }
107 : {- empty -} { (\ tc_occ -> []) }
108 | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
109 con_info = PrefixCon [toHsType $2] }
110 in [noLoc $ ConDecl (noLoc dc_name) Explicit []
111 (noLoc []) con_info ResTyH98]) }
113 cons :: { [LConDecl RdrName] }
114 : {- empty -} { [] } -- 20060420 Empty data types allowed. jds
115 | con ';' cons { $1:$3 }
117 con :: { LConDecl RdrName }
118 : d_pat_occ attv_bndrs hs_atys
119 { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98}
121 -- XXX - audreyt - $3 needs to be split into argument and return types!
122 -- also not sure whether the [] below (quantified vars) appears.
123 -- also the "PrefixCon []" is wrong.
124 -- also we want to munge $3 somehow.
125 -- extractWhatEver to unpack ty into the parts to ConDecl
126 -- XXX - define it somewhere in RdrHsSyn
127 { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) }
129 attv_bndrs :: { [LHsTyVarBndr RdrName] }
131 | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 }
133 hs_atys :: { [LHsType RdrName] }
134 : atys { map toHsType $1 }
137 ---------------------------------------
139 ---------------------------------------
141 atys :: { [IfaceType] }
146 : tv_occ { IfaceTyVar $1 }
147 | q_tc_name { IfaceTyConApp (IfaceTc $1) [] }
151 : tv_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 }
152 | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 }
157 | bty '->' ty { IfaceFunTy $1 $3 }
158 | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 }
160 ----------------------------------------------
161 -- Bindings are in Iface syntax
163 vdefgs :: { [IfaceBinding] }
165 | let_bind ';' vdefgs { $1 : $3 }
167 let_bind :: { IfaceBinding }
168 : '%rec' '{' vdefs1 '}' { IfaceRec $3 }
169 | vdef { let (b,r) = $1
172 vdefs1 :: { [(IfaceIdBndr, IfaceExpr)] }
174 | vdef ';' vdefs1 { $1:$3 }
176 vdef :: { (IfaceIdBndr, IfaceExpr) }
177 : qd_occ '::' ty '=' exp { (($1, $3), $5) }
178 -- NB: qd_occ includes data constructors, because
179 -- we allow data-constructor wrappers at top level
180 -- But we discard the module name, because it must be the
181 -- same as the module being compiled, and Iface syntax only
182 -- has OccNames in binding positions
184 qd_occ :: { FastString }
188 ---------------------------------------
190 bndr :: { IfaceBndr }
191 : '@' tv_bndr { IfaceTvBndr $2 }
192 | id_bndr { IfaceIdBndr $1 }
194 bndrs :: { [IfaceBndr] }
196 | bndr bndrs { $1:$2 }
198 id_bndr :: { IfaceIdBndr }
199 : '(' var_occ '::' ty ')' { ($2,$4) }
201 id_bndrs :: { [IfaceIdBndr] }
203 | id_bndr id_bndrs { $1:$2 }
205 tv_bndr :: { IfaceTvBndr }
206 : tv_occ { ($1, ifaceLiftedTypeKind) }
207 | '(' tv_occ '::' akind ')' { ($2, $4) }
209 tv_bndrs :: { [IfaceTvBndr] }
211 | tv_bndr tv_bndrs { $1:$2 }
213 akind :: { IfaceKind }
214 : '*' { ifaceLiftedTypeKind }
215 | '#' { ifaceUnliftedTypeKind }
216 | '?' { ifaceOpenTypeKind }
217 | '(' kind ')' { $2 }
219 kind :: { IfaceKind }
221 | akind '->' kind { ifaceArrow $1 $3 }
223 -----------------------------------------
226 aexp :: { IfaceExpr }
227 : var_occ { IfaceLcl $1 }
228 | modid '.' qd_occ { IfaceExt (ExtPkg $1 (mkVarOccFS $3)) }
229 | lit { IfaceLit $1 }
232 fexp :: { IfaceExpr }
233 : fexp aexp { IfaceApp $1 $2 }
234 | fexp '@' aty { IfaceApp $1 (IfaceType $3) }
239 | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 }
240 | '%let' let_bind '%in' exp { IfaceLet $2 $4 }
242 | '%case' '(' ty ')' aexp '%of' id_bndr
243 '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 }
244 | '%cast' exp aty { IfaceCast $2 $3 }
247 --"SCC" -> IfaceNote (IfaceSCC "scc") $3
248 "InlineMe" -> IfaceNote IfaceInlineMe $3
250 | '%external' STRING aty { IfaceFCall (ForeignCall.CCall
251 (CCallSpec (StaticTarget (mkFastString $2))
252 CCallConv (PlaySafe False)))
255 alts1 :: { [IfaceAlt] }
257 | alt ';' alts1 { $1:$3 }
260 : modid '.' d_pat_occ bndrs '->' exp
261 { (IfaceDataAlt $3, map ifaceBndrName $4, $6) }
262 -- The external syntax currently includes the types of the
263 -- the args, but they aren't needed internally
264 -- Nor is the module qualifier
266 { (IfaceLitAlt $1, [], $3) }
268 { (IfaceDefault, [], $3) }
271 : '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
272 | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
273 | '(' CHAR '::' aty ')' { MachChar $2 }
274 | '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
276 tv_occ :: { FastString }
277 : NAME { mkFastString $1 }
279 var_occ :: { FastString }
280 : NAME { mkFastString $1 }
284 q_tc_name :: { IfaceExtName }
285 : modid '.' CNAME { ExtPkg $1 (mkOccName tcName $3) }
287 -- Data constructor in a pattern or data type declaration; use the dataName,
288 -- because that's what we expect in Core case patterns
289 d_pat_occ :: { OccName }
290 : CNAME { mkOccName dataName $1 }
292 -- Data constructor occurrence in an expression;
293 -- use the varName because that's the worker Id
294 d_occ :: { FastString }
295 : CNAME { mkFastString $1 }
299 ifaceKind kc = IfaceTyConApp kc []
301 ifaceBndrName (IfaceIdBndr (n,_)) = n
302 ifaceBndrName (IfaceTvBndr (n,_)) = n
304 convIntLit :: Integer -> IfaceType -> Literal
305 convIntLit i (IfaceTyConApp tc [])
306 | tc `eqTc` intPrimTyCon = MachInt i
307 | tc `eqTc` wordPrimTyCon = MachWord i
308 | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i))
309 | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr
311 = pprPanic "Unknown integer literal type" (ppr aty)
313 convRatLit :: Rational -> IfaceType -> Literal
314 convRatLit r (IfaceTyConApp tc [])
315 | tc `eqTc` floatPrimTyCon = MachFloat r
316 | tc `eqTc` doublePrimTyCon = MachDouble r
318 = pprPanic "Unknown rational literal type" (ppr aty)
320 eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh!
321 eqTc (IfaceTc (ExtPkg mod occ)) tycon
322 = mod == nameModule nm && occ == nameOccName nm
326 -- Tiresomely, we have to generate both HsTypes (in type/class decls)
327 -- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes,
328 -- and convert to HsTypes here. But the IfaceTypes we can see here
329 -- are very limited (see the productions for 'ty', so the translation
331 toHsType :: IfaceType -> LHsType RdrName
332 toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOcc v))
333 toHsType (IfaceAppTy t1 t2) = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
334 toHsType (IfaceFunTy t1 t2) = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
335 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts)
336 toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t)
338 -- We also need to convert IfaceKinds to Kinds (now that they are different).
339 -- Only a limited form of kind will be encountered... hopefully
340 toKind :: IfaceKind -> Kind
341 toKind (IfaceFunTy ifK1 ifK2) = mkArrowKind (toKind ifK1) (toKind ifK2)
342 toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) []
343 toKind other = pprPanic "toKind" (ppr other)
345 toKindTc :: IfaceTyCon -> TyCon
346 toKindTc IfaceLiftedTypeKindTc = liftedTypeKindTyCon
347 toKindTc IfaceOpenTypeKindTc = openTypeKindTyCon
348 toKindTc IfaceUnliftedTypeKindTc = unliftedTypeKindTyCon
349 toKindTc IfaceUbxTupleKindTc = ubxTupleKindTyCon
350 toKindTc IfaceArgTypeKindTc = argTypeKindTyCon
351 toKindTc other = pprPanic "toKindTc" (ppr other)
353 ifaceTcType ifTc = IfaceTyConApp ifTc []
355 ifaceLiftedTypeKind = ifaceTcType IfaceLiftedTypeKindTc
356 ifaceOpenTypeKind = ifaceTcType IfaceOpenTypeKindTc
357 ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc
359 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
361 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
362 toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) (toKind k)
364 ifaceExtRdrName :: IfaceExtName -> RdrName
365 ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ
366 ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
368 add_forall tv (L _ (HsForAllTy exp tvs cxt t))
369 = noLoc $ HsForAllTy exp (tv:tvs) cxt t
371 = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
374 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l