2 module ParserCore ( parseCore ) where
11 liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
12 argTypeKindTyCon, ubxTupleKindTyCon, mkArrowKind, mkTyConApp
14 import Name( Name, nameOccName, nameModule, mkExternalName )
16 import PackageConfig ( mainPackageId, stringToPackageId )
17 import ParserCoreUtils
21 import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon,
22 floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
23 import TyCon ( TyCon, tyConName )
29 #include "../HsVersions.h"
37 '%module' { TKmodule }
39 '%newtype' { TKnewtype }
40 '%forall' { TKforall }
48 '%external' { TKexternal }
59 ':=:' { TKcoloneqcolon }
69 INTEGER { TKinteger $$ }
70 RATIONAL { TKrational $$ }
71 STRING { TKstring $$ }
74 %monad { P } { thenP } { returnP }
75 %lexer { lexer } { TKEOF }
79 module :: { HsExtCore RdrName }
80 -- : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 }
81 : '%module' modid tdefs vdefgs { HsExtCore $2 [] [] }
84 -------------------------------------------------------------
85 -- Names: the trickiest bit in here
87 -- A name of the form A.B.C could be:
89 -- dcon C in module A.B
90 -- tcon C in module A.B
92 : NAME ':' mparts { undefined }
95 : NAME ':' mparts { undefined }
98 : NAME ':' mparts { undefined }
100 q_var_occ :: { Name }
101 : NAME ':' vparts { undefined }
103 mparts :: { [String] }
105 | CNAME '.' mparts { $1:$3 }
107 vparts :: { [String] }
109 | CNAME '.' vparts { $1:$3 }
111 -------------------------------------------------------------
112 -- Type and newtype declarations are in HsSyn syntax
114 tdefs :: { [TyClDecl RdrName] }
118 tdef :: { TyClDecl RdrName }
119 : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
120 { mkTyData DataType ( noLoc []
121 , noLoc (ifaceExtRdrName $2)
124 ) Nothing $6 Nothing }
125 | '%newtype' q_tc_name tv_bndrs trep ';'
126 { let tc_rdr = ifaceExtRdrName $2 in
127 mkTyData NewType ( noLoc []
131 ) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
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]) }
142 cons :: { [LConDecl RdrName] }
143 : {- empty -} { [] } -- 20060420 Empty data types allowed. jds
145 | con ';' cons { $1:$3 }
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 }
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 }
159 attv_bndrs :: { [LHsTyVarBndr RdrName] }
161 | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 }
163 hs_atys :: { [LHsType RdrName] }
164 : atys { map toHsType $1 }
167 ---------------------------------------
169 ---------------------------------------
171 atys :: { [IfaceType] }
176 : fs_var_occ { IfaceTyVar $1 }
177 | q_tc_name { IfaceTyConApp (IfaceTc $1) [] }
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 }
188 | bty '->' ty { IfaceFunTy $1 $3 }
189 | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 }
191 ----------------------------------------------
192 -- Bindings are in Iface syntax
194 vdefgs :: { [IfaceBinding] }
196 | let_bind ';' vdefgs { $1 : $3 }
198 let_bind :: { IfaceBinding }
199 : '%rec' '{' vdefs1 '}' { IfaceRec $3 } -- Can be empty. Do we care?
200 | vdef { let (b,r) = $1
203 vdefs1 :: { [(IfaceIdBndr, IfaceExpr)] }
205 | vdef ';' vdefs1 { $1:$3 }
207 vdef :: { (IfaceIdBndr, IfaceExpr) }
208 : fs_var_occ '::' ty '=' exp { (($1, $3), $5) }
209 | '%local' vdef { $2 }
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!
217 ---------------------------------------
219 bndr :: { IfaceBndr }
220 : '@' tv_bndr { IfaceTvBndr $2 }
221 | id_bndr { IfaceIdBndr $1 }
223 bndrs :: { [IfaceBndr] }
225 | bndr bndrs { $1:$2 }
227 id_bndr :: { IfaceIdBndr }
228 : '(' fs_var_occ '::' ty ')' { ($2,$4) }
230 tv_bndr :: { IfaceTvBndr }
231 : fs_var_occ { ($1, ifaceLiftedTypeKind) }
232 | '(' fs_var_occ '::' akind ')' { ($2, $4) }
234 tv_bndrs :: { [IfaceTvBndr] }
236 | tv_bndr tv_bndrs { $1:$2 }
238 akind :: { IfaceKind }
239 : '*' { ifaceLiftedTypeKind }
240 | '#' { ifaceUnliftedTypeKind }
241 | '?' { ifaceOpenTypeKind }
242 | '(' kind ')' { $2 }
244 kind :: { IfaceKind }
246 | akind '->' kind { ifaceArrow $1 $3 }
247 | ty ':=:' ty { ifaceEq $1 $3 }
249 -----------------------------------------
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 }
259 fexp :: { IfaceExpr }
260 : fexp aexp { IfaceApp $1 $2 }
261 | fexp '@' aty { IfaceApp $1 (IfaceType $3) }
266 | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 }
267 | '%let' let_bind '%in' exp { IfaceLet $2 $4 }
269 | '%case' '(' ty ')' aexp '%of' id_bndr
270 '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 }
271 | '%cast' aexp aty { IfaceCast $2 $3 }
274 --"SCC" -> IfaceNote (IfaceSCC "scc") $3
275 "InlineMe" -> IfaceNote IfaceInlineMe $3
277 | '%external' STRING aty { IfaceFCall (ForeignCall.CCall
278 (CCallSpec (StaticTarget (mkFastString $2))
279 CCallConv (PlaySafe False)))
282 alts1 :: { [IfaceAlt] }
284 | alt ';' alts1 { $1:$3 }
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
293 { (IfaceDataAlt $1, [], $3) }
295 { (IfaceLitAlt $1, [], $3) }
297 { (IfaceDefault, [], $3) }
300 : '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
301 | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
302 | '(' CHAR '::' aty ')' { MachChar $2 }
303 | '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
305 fs_var_occ :: { FastString }
306 : NAME { mkFastString $1 }
308 var_occ :: { String }
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 }
319 ifaceKind kc = IfaceTyConApp kc []
321 ifaceBndrName (IfaceIdBndr (n,_)) = n
322 ifaceBndrName (IfaceTvBndr (n,_)) = n
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
331 = pprPanic "Unknown integer literal type" (ppr aty)
333 convRatLit :: Rational -> IfaceType -> Literal
334 convRatLit r (IfaceTyConApp tc [])
335 | tc `eqTc` floatPrimTyCon = MachFloat r
336 | tc `eqTc` doublePrimTyCon = MachDouble r
338 = pprPanic "Unknown rational literal type" (ppr aty)
340 eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh!
341 eqTc (IfaceTc name) tycon = name == tyConName tycon
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
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)
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)
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)
370 ifaceTcType ifTc = IfaceTyConApp ifTc []
372 ifaceLiftedTypeKind = ifaceTcType IfaceLiftedTypeKindTc
373 ifaceOpenTypeKind = ifaceTcType IfaceOpenTypeKindTc
374 ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc
376 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
378 ifaceEq ifT1 ifT2 = IfacePredTy (IfaceEqPred ifT1 ifT2)
380 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
381 toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) (toKind k)
383 ifaceExtRdrName :: Name -> RdrName
384 ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
385 ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
387 add_forall tv (L _ (HsForAllTy exp tvs cxt t))
388 = noLoc $ HsForAllTy exp (tv:tvs) cxt t
390 = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
393 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l