2 module ParserCore ( parseCore ) where
10 import Kind( Kind(..) )
11 import Name( nameOccName, nameModule )
13 import PackageConfig ( mainPackageId )
14 import ParserCoreUtils
18 import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon,
19 floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
20 import TyCon ( TyCon, tyConName )
25 #include "../HsVersions.h"
33 '%module' { TKmodule }
35 '%newtype' { TKnewtype }
36 '%forall' { TKforall }
42 '%coerce' { TKcoerce }
44 '%external' { TKexternal }
62 INTEGER { TKinteger $$ }
63 RATIONAL { TKrational $$ }
64 STRING { TKstring $$ }
67 %monad { P } { thenP } { returnP }
68 %lexer { lexer } { TKEOF }
72 module :: { HsExtCore RdrName }
73 : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 }
76 : CNAME { mkModule mainPackageId -- ToDo: wrong
77 (mkModuleNameFS (mkFastString $1)) }
79 -------------------------------------------------------------
80 -- Type and newtype declarations are in HsSyn syntax
82 tdefs :: { [TyClDecl RdrName] }
84 | tdef ';' tdefs {$1:$3}
86 tdef :: { TyClDecl RdrName }
87 : '%data' q_tc_name tv_bndrs '=' '{' cons '}'
88 { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) Nothing $6 Nothing }
89 | '%newtype' q_tc_name tv_bndrs trep
90 { let tc_rdr = ifaceExtRdrName $2 in
91 mkTyData NewType (noLoc [], noLoc tc_rdr, map toHsTvBndr $3) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
93 -- For a newtype we have to invent a fake data constructor name
94 -- It doesn't matter what it is, because it won't be used
95 trep :: { OccName -> [LConDecl RdrName] }
96 : {- empty -} { (\ tc_occ -> []) }
97 | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
98 con_info = PrefixCon [toHsType $2] }
99 in [noLoc $ ConDecl (noLoc dc_name) Explicit []
100 (noLoc []) con_info ResTyH98]) }
102 cons :: { [LConDecl RdrName] }
103 : {- empty -} { [] } -- 20060420 Empty data types allowed. jds
104 | con ';' cons { $1:$3 }
106 con :: { LConDecl RdrName }
107 : d_pat_occ attv_bndrs hs_atys
108 { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98}
110 -- XXX - autrijus - $3 needs to be split into argument and return types!
111 -- also not sure whether the [] below (quantified vars) appears.
112 -- also the "PrefixCon []" is wrong.
113 -- also we want to munge $3 somehow.
114 -- extractWhatEver to unpack ty into the parts to ConDecl
115 -- XXX - define it somewhere in RdrHsSyn
116 { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) }
118 attv_bndrs :: { [LHsTyVarBndr RdrName] }
120 | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 }
122 hs_atys :: { [LHsType RdrName] }
123 : atys { map toHsType $1 }
126 ---------------------------------------
128 ---------------------------------------
130 atys :: { [IfaceType] }
135 : tv_occ { IfaceTyVar $1 }
136 | q_tc_name { IfaceTyConApp (IfaceTc $1) [] }
140 : tv_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 }
141 | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 }
146 | bty '->' ty { IfaceFunTy $1 $3 }
147 | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 }
149 ----------------------------------------------
150 -- Bindings are in Iface syntax
152 vdefgs :: { [IfaceBinding] }
154 | let_bind ';' vdefgs { $1 : $3 }
156 let_bind :: { IfaceBinding }
157 : '%rec' '{' vdefs1 '}' { IfaceRec $3 }
158 | vdef { let (b,r) = $1
161 vdefs1 :: { [(IfaceIdBndr, IfaceExpr)] }
163 | vdef ';' vdefs1 { $1:$3 }
165 vdef :: { (IfaceIdBndr, IfaceExpr) }
166 : qd_occ '::' ty '=' exp { (($1, $3), $5) }
167 -- NB: qd_occ includes data constructors, because
168 -- we allow data-constructor wrappers at top level
169 -- But we discard the module name, because it must be the
170 -- same as the module being compiled, and Iface syntax only
171 -- has OccNames in binding positions
173 qd_occ :: { FastString }
177 ---------------------------------------
179 bndr :: { IfaceBndr }
180 : '@' tv_bndr { IfaceTvBndr $2 }
181 | id_bndr { IfaceIdBndr $1 }
183 bndrs :: { [IfaceBndr] }
185 | bndr bndrs { $1:$2 }
187 id_bndr :: { IfaceIdBndr }
188 : '(' var_occ '::' ty ')' { ($2,$4) }
190 id_bndrs :: { [IfaceIdBndr] }
192 | id_bndr id_bndrs { $1:$2 }
194 tv_bndr :: { IfaceTvBndr }
195 : tv_occ { ($1, LiftedTypeKind) }
196 | '(' tv_occ '::' akind ')' { ($2, $4) }
198 tv_bndrs :: { [IfaceTvBndr] }
200 | tv_bndr tv_bndrs { $1:$2 }
202 akind :: { IfaceKind }
203 : '*' { LiftedTypeKind }
204 | '#' { UnliftedTypeKind }
205 | '?' { OpenTypeKind }
206 | '(' kind ')' { $2 }
208 kind :: { IfaceKind }
210 | akind '->' kind { FunKind $1 $3 }
212 -----------------------------------------
215 aexp :: { IfaceExpr }
216 : var_occ { IfaceLcl $1 }
217 | modid '.' qd_occ { IfaceExt (ExtPkg $1 (mkVarOccFS $3)) }
218 | lit { IfaceLit $1 }
221 fexp :: { IfaceExpr }
222 : fexp aexp { IfaceApp $1 $2 }
223 | fexp '@' aty { IfaceApp $1 (IfaceType $3) }
228 | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 }
229 | '%let' let_bind '%in' exp { IfaceLet $2 $4 }
231 | '%case' '(' ty ')' aexp '%of' id_bndr
232 '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 }
233 | '%coerce' aty exp { IfaceNote (IfaceCoerce $2) $3 }
236 --"SCC" -> IfaceNote (IfaceSCC "scc") $3
237 "InlineMe" -> IfaceNote IfaceInlineMe $3
239 | '%external' STRING aty { IfaceFCall (ForeignCall.CCall
240 (CCallSpec (StaticTarget (mkFastString $2))
241 CCallConv (PlaySafe False)))
244 alts1 :: { [IfaceAlt] }
246 | alt ';' alts1 { $1:$3 }
249 : modid '.' d_pat_occ bndrs '->' exp
250 { (IfaceDataAlt $3, map ifaceBndrName $4, $6) }
251 -- The external syntax currently includes the types of the
252 -- the args, but they aren't needed internally
253 -- Nor is the module qualifier
255 { (IfaceLitAlt $1, [], $3) }
257 { (IfaceDefault, [], $3) }
260 : '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
261 | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
262 | '(' CHAR '::' aty ')' { MachChar $2 }
263 | '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
265 tv_occ :: { FastString }
266 : NAME { mkFastString $1 }
268 var_occ :: { FastString }
269 : NAME { mkFastString $1 }
273 q_tc_name :: { IfaceExtName }
274 : modid '.' CNAME { ExtPkg $1 (mkOccName tcName $3) }
276 -- Data constructor in a pattern or data type declaration; use the dataName,
277 -- because that's what we expect in Core case patterns
278 d_pat_occ :: { OccName }
279 : CNAME { mkOccName dataName $1 }
281 -- Data constructor occurrence in an expression;
282 -- use the varName because that's the worker Id
283 d_occ :: { FastString }
284 : CNAME { mkFastString $1 }
288 ifaceBndrName (IfaceIdBndr (n,_)) = n
289 ifaceBndrName (IfaceTvBndr (n,_)) = n
291 convIntLit :: Integer -> IfaceType -> Literal
292 convIntLit i (IfaceTyConApp tc [])
293 | tc `eqTc` intPrimTyCon = MachInt i
294 | tc `eqTc` wordPrimTyCon = MachWord i
295 | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i))
296 | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr
298 = pprPanic "Unknown integer literal type" (ppr aty)
300 convRatLit :: Rational -> IfaceType -> Literal
301 convRatLit r (IfaceTyConApp tc [])
302 | tc `eqTc` floatPrimTyCon = MachFloat r
303 | tc `eqTc` doublePrimTyCon = MachDouble r
305 = pprPanic "Unknown rational literal type" (ppr aty)
307 eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh!
308 eqTc (IfaceTc (ExtPkg mod occ)) tycon
309 = mod == nameModule nm && occ == nameOccName nm
313 -- Tiresomely, we have to generate both HsTypes (in type/class decls)
314 -- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes,
315 -- and convert to HsTypes here. But the IfaceTypes we can see here
316 -- are very limited (see the productions for 'ty', so the translation
318 toHsType :: IfaceType -> LHsType RdrName
319 toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOcc v))
320 toHsType (IfaceAppTy t1 t2) = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
321 toHsType (IfaceFunTy t1 t2) = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
322 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts)
323 toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t)
325 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
326 toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) k
328 ifaceExtRdrName :: IfaceExtName -> RdrName
329 ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ
330 ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
332 add_forall tv (L _ (HsForAllTy exp tvs cxt t))
333 = noLoc $ HsForAllTy exp (tv:tvs) cxt t
335 = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
338 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l