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 [], 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 }
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]) }
105 cons :: { [LConDecl RdrName] }
106 : {- empty -} { [] } -- 20060420 Empty data types allowed. jds
107 | con ';' cons { $1:$3 }
109 con :: { LConDecl RdrName }
110 : d_pat_occ attv_bndrs hs_atys
111 { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98}
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) }
121 attv_bndrs :: { [LHsTyVarBndr RdrName] }
123 | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 }
125 hs_atys :: { [LHsType RdrName] }
126 : atys { map toHsType $1 }
129 ---------------------------------------
131 ---------------------------------------
133 atys :: { [IfaceType] }
138 : tv_occ { IfaceTyVar $1 }
139 | q_tc_name { IfaceTyConApp (IfaceTc $1) [] }
143 : tv_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 }
144 | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 }
149 | bty '->' ty { IfaceFunTy $1 $3 }
150 | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 }
152 ----------------------------------------------
153 -- Bindings are in Iface syntax
155 vdefgs :: { [IfaceBinding] }
157 | let_bind ';' vdefgs { $1 : $3 }
159 let_bind :: { IfaceBinding }
160 : '%rec' '{' vdefs1 '}' { IfaceRec $3 }
161 | vdef { let (b,r) = $1
164 vdefs1 :: { [(IfaceIdBndr, IfaceExpr)] }
166 | vdef ';' vdefs1 { $1:$3 }
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
176 qd_occ :: { FastString }
180 ---------------------------------------
182 bndr :: { IfaceBndr }
183 : '@' tv_bndr { IfaceTvBndr $2 }
184 | id_bndr { IfaceIdBndr $1 }
186 bndrs :: { [IfaceBndr] }
188 | bndr bndrs { $1:$2 }
190 id_bndr :: { IfaceIdBndr }
191 : '(' var_occ '::' ty ')' { ($2,$4) }
193 id_bndrs :: { [IfaceIdBndr] }
195 | id_bndr id_bndrs { $1:$2 }
197 tv_bndr :: { IfaceTvBndr }
198 : tv_occ { ($1, ifaceLiftedTypeKind) }
199 | '(' tv_occ '::' akind ')' { ($2, $4) }
201 tv_bndrs :: { [IfaceTvBndr] }
203 | tv_bndr tv_bndrs { $1:$2 }
205 akind :: { IfaceKind }
206 : '*' { ifaceLiftedTypeKind }
207 | '#' { ifaceUnliftedTypeKind }
208 | '?' { ifaceOpenTypeKind }
209 | '(' kind ')' { $2 }
211 kind :: { IfaceKind }
213 | akind '->' kind { ifaceArrow $1 $3 }
215 -----------------------------------------
218 aexp :: { IfaceExpr }
219 : var_occ { IfaceLcl $1 }
220 | modid '.' qd_occ { IfaceExt (ExtPkg $1 (mkVarOccFS $3)) }
221 | lit { IfaceLit $1 }
224 fexp :: { IfaceExpr }
225 : fexp aexp { IfaceApp $1 $2 }
226 | fexp '@' aty { IfaceApp $1 (IfaceType $3) }
231 | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 }
232 | '%let' let_bind '%in' exp { IfaceLet $2 $4 }
234 | '%case' '(' ty ')' aexp '%of' id_bndr
235 '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 }
236 | '%cast' exp aty { IfaceCast $2 $3 }
239 --"SCC" -> IfaceNote (IfaceSCC "scc") $3
240 "InlineMe" -> IfaceNote IfaceInlineMe $3
242 | '%external' STRING aty { IfaceFCall (ForeignCall.CCall
243 (CCallSpec (StaticTarget (mkFastString $2))
244 CCallConv (PlaySafe False)))
247 alts1 :: { [IfaceAlt] }
249 | alt ';' alts1 { $1:$3 }
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
258 { (IfaceLitAlt $1, [], $3) }
260 { (IfaceDefault, [], $3) }
263 : '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
264 | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
265 | '(' CHAR '::' aty ')' { MachChar $2 }
266 | '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
268 tv_occ :: { FastString }
269 : NAME { mkFastString $1 }
271 var_occ :: { FastString }
272 : NAME { mkFastString $1 }
276 q_tc_name :: { IfaceExtName }
277 : modid '.' CNAME { ExtPkg $1 (mkOccName tcName $3) }
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 }
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 }
291 ifaceKind kc = IfaceTyConApp kc []
293 ifaceBndrName (IfaceIdBndr (n,_)) = n
294 ifaceBndrName (IfaceTvBndr (n,_)) = n
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
303 = pprPanic "Unknown integer literal type" (ppr aty)
305 convRatLit :: Rational -> IfaceType -> Literal
306 convRatLit r (IfaceTyConApp tc [])
307 | tc `eqTc` floatPrimTyCon = MachFloat r
308 | tc `eqTc` doublePrimTyCon = MachDouble r
310 = pprPanic "Unknown rational literal type" (ppr aty)
312 eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh!
313 eqTc (IfaceTc (ExtPkg mod occ)) tycon
314 = mod == nameModule nm && occ == nameOccName nm
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
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)
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)
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)
345 ifaceTcType ifTc = IfaceTyConApp ifTc []
347 ifaceLiftedTypeKind = ifaceTcType IfaceLiftedTypeKindTc
348 ifaceOpenTypeKind = ifaceTcType IfaceOpenTypeKindTc
349 ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc
351 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
353 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
354 toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) (toKind k)
356 ifaceExtRdrName :: IfaceExtName -> RdrName
357 ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ
358 ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
360 add_forall tv (L _ (HsForAllTy exp tvs cxt t))
361 = noLoc $ HsForAllTy exp (tv:tvs) cxt t
363 = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
366 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l