2 module ParserCore ( parseCore ) where
7 import TcIface ( tcIfaceKind )
11 import Name( nameOccName, nameModuleName )
13 import ParserCoreUtils
18 import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon,
19 floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
20 import TyCon ( TyCon, tyConName )
24 #include "../HsVersions.h"
32 '%module' { TKmodule }
34 '%newtype' { TKnewtype }
35 '%forall' { TKforall }
41 '%coerce' { TKcoerce }
43 '%external' { TKexternal }
61 INTEGER { TKinteger $$ }
62 RATIONAL { TKrational $$ }
63 STRING { TKstring $$ }
66 %monad { P } { thenP } { returnP }
67 %lexer { lexer } { TKEOF }
71 module :: { HsExtCore RdrName }
72 : '%module' modid tdefs vdefgs
73 { HsExtCore (mkHomeModule $2) $3 $4 }
75 modid :: { ModuleName }
76 : CNAME { mkSysModuleNameFS (mkFastString $1) }
78 -------------------------------------------------------------
79 -- Type and newtype declarations are in HsSyn syntax
81 tdefs :: { [TyClDecl RdrName] }
83 | tdef ';' tdefs {$1:$3}
85 tdef :: { TyClDecl RdrName }
86 : '%data' q_tc_name tv_bndrs '=' '{' cons1 '}'
87 { mkTyData DataType ([], ifaceExtRdrName $2, map toHsTvBndr $3) $6 Nothing noSrcLoc }
88 | '%newtype' q_tc_name tv_bndrs trep
89 { let tc_rdr = ifaceExtRdrName $2 in
90 mkTyData NewType ([], tc_rdr, map toHsTvBndr $3) ($4 (rdrNameOcc tc_rdr)) Nothing noSrcLoc }
92 -- For a newtype we have to invent a fake data constructor name
93 -- It doesn't matter what it is, because it won't be used
94 trep :: { OccName -> [ConDecl RdrName] }
95 : {- empty -} { (\ tc_occ -> []) }
96 | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
97 con_info = PrefixCon [unbangedType (toHsType $2)] }
98 in [ConDecl dc_name [] [] con_info noSrcLoc]) }
100 cons1 :: { [ConDecl RdrName] }
102 | con ';' cons1 { $1:$3 }
104 con :: { ConDecl RdrName }
105 : d_pat_occ attv_bndrs hs_atys
106 { ConDecl (mkRdrUnqual $1) $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
108 attv_bndrs :: { [HsTyVarBndr RdrName] }
110 | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 }
112 hs_atys :: { [HsType RdrName] }
113 : atys { map toHsType $1 }
116 ---------------------------------------
118 ---------------------------------------
120 atys :: { [IfaceType] }
125 : tv_occ { IfaceTyVar $1 }
126 | q_tc_name { IfaceTyConApp (IfaceTc $1) [] }
130 : tv_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 }
131 | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 }
135 | bty '->' ty { IfaceFunTy $1 $3 }
136 | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 }
138 ----------------------------------------------
139 -- Bindings are in Iface syntax
141 vdefgs :: { [IfaceBinding] }
143 | let_bind ';' vdefgs { $1 : $3 }
145 let_bind :: { IfaceBinding }
146 : '%rec' '{' vdefs1 '}' { IfaceRec $3 }
147 | vdef { let (b,r) = $1
150 vdefs1 :: { [(IfaceIdBndr, IfaceExpr)] }
152 | vdef ';' vdefs1 { $1:$3 }
154 vdef :: { (IfaceIdBndr, IfaceExpr) }
155 : qd_occ '::' ty '=' exp { (($1, $3), $5) }
156 -- NB: qd_occ includes data constructors, because
157 -- we allow data-constructor wrappers at top level
158 -- But we discard the module name, because it must be the
159 -- same as the module being compiled, and Iface syntax only
160 -- has OccNames in binding positions
162 qd_occ :: { OccName }
166 ---------------------------------------
168 bndr :: { IfaceBndr }
169 : '@' tv_bndr { IfaceTvBndr $2 }
170 | id_bndr { IfaceIdBndr $1 }
172 bndrs :: { [IfaceBndr] }
174 | bndr bndrs { $1:$2 }
176 id_bndr :: { IfaceIdBndr }
177 : '(' var_occ '::' ty ')' { ($2,$4) }
179 id_bndrs :: { [IfaceIdBndr] }
181 | id_bndr id_bndrs { $1:$2 }
183 tv_bndr :: { IfaceTvBndr }
184 : tv_occ { ($1, IfaceLiftedTypeKind) }
185 | '(' tv_occ '::' akind ')' { ($2, $4) }
187 tv_bndrs :: { [IfaceTvBndr] }
189 | tv_bndr tv_bndrs { $1:$2 }
191 akind :: { IfaceKind }
192 : '*' { IfaceLiftedTypeKind }
193 | '#' { IfaceUnliftedTypeKind }
194 | '?' { IfaceOpenTypeKind }
195 | '(' kind ')' { $2 }
197 kind :: { IfaceKind }
199 | akind '->' kind { IfaceFunKind $1 $3 }
201 -----------------------------------------
204 aexp :: { IfaceExpr }
205 : var_occ { IfaceLcl $1 }
206 | modid '.' qd_occ { IfaceExt (ExtPkg $1 $3) }
207 | lit { IfaceLit $1 }
210 fexp :: { IfaceExpr }
211 : fexp aexp { IfaceApp $1 $2 }
212 | fexp '@' aty { IfaceApp $1 (IfaceType $3) }
217 | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 }
218 | '%let' let_bind '%in' exp { IfaceLet $2 $4 }
219 | '%case' aexp '%of' id_bndr
220 '{' alts1 '}' { IfaceCase $2 (fst $4) $6 }
221 | '%coerce' aty exp { IfaceNote (IfaceCoerce $2) $3 }
224 --"SCC" -> IfaceNote (IfaceSCC "scc") $3
225 "InlineCall" -> IfaceNote IfaceInlineCall $3
226 "InlineMe" -> IfaceNote IfaceInlineMe $3
228 | '%external' STRING aty { IfaceFCall (ForeignCall.CCall
229 (CCallSpec (StaticTarget (mkFastString $2))
230 CCallConv (PlaySafe False)))
233 alts1 :: { [IfaceAlt] }
235 | alt ';' alts1 { $1:$3 }
238 : modid '.' d_pat_occ bndrs '->' exp
239 { (IfaceDataAlt $3, map ifaceBndrName $4, $6) }
240 -- The external syntax currently includes the types of the
241 -- the args, but they aren't needed internally
242 -- Nor is the module qualifier
244 { (IfaceLitAlt $1, [], $3) }
246 { (IfaceDefault, [], $3) }
249 : '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
250 | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
251 | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) }
252 | '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
254 tv_occ :: { OccName }
255 : NAME { mkSysOcc tvName $1 }
257 var_occ :: { OccName }
258 : NAME { mkSysOcc varName $1 }
262 q_tc_name :: { IfaceExtName }
263 : modid '.' CNAME { ExtPkg $1 (mkSysOcc tcName $3) }
265 -- Data constructor in a pattern or data type declaration; use the dataName,
266 -- because that's what we expect in Core case patterns
267 d_pat_occ :: { OccName }
268 : CNAME { mkSysOcc dataName $1 }
270 -- Data constructor occurrence in an expression;
271 -- use the varName because that's the worker Id
273 : CNAME { mkSysOcc varName $1 }
277 ifaceBndrName (IfaceIdBndr (n,_)) = n
278 ifaceBndrName (IfaceTvBndr (n,_)) = n
280 convIntLit :: Integer -> IfaceType -> Literal
281 convIntLit i (IfaceTyConApp tc [])
282 | tc `eqTc` intPrimTyCon = MachInt i
283 | tc `eqTc` wordPrimTyCon = MachWord i
284 | tc `eqTc` charPrimTyCon = MachChar (fromInteger i)
285 | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr
287 = pprPanic "Unknown integer literal type" (ppr aty)
289 convRatLit :: Rational -> IfaceType -> Literal
290 convRatLit r (IfaceTyConApp tc [])
291 | tc `eqTc` floatPrimTyCon = MachFloat r
292 | tc `eqTc` doublePrimTyCon = MachDouble r
294 = pprPanic "Unknown rational literal type" (ppr aty)
296 eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh!
297 eqTc (IfaceTc (ExtPkg mod occ)) tycon
298 = mod == nameModuleName nm && occ == nameOccName nm
302 -- Tiresomely, we have to generate both HsTypes (in type/class decls)
303 -- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes,
304 -- and convert to HsTypes here. But the IfaceTypes we can see here
305 -- are very limited (see the productions for 'ty', so the translation
307 toHsType :: IfaceType -> HsType RdrName
308 toHsType (IfaceTyVar v) = HsTyVar (mkRdrUnqual v)
309 toHsType (IfaceAppTy t1 t2) = HsAppTy (toHsType t1) (toHsType t2)
310 toHsType (IfaceFunTy t1 t2) = HsFunTy (toHsType t1) (toHsType t2)
311 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl HsAppTy (HsTyVar (ifaceExtRdrName tc)) (map toHsType ts)
312 toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t)
314 toHsTvBndr :: IfaceTvBndr -> HsTyVarBndr RdrName
315 toHsTvBndr (tv,k) = KindedTyVar (mkRdrUnqual tv) (tcIfaceKind k)
317 ifaceExtRdrName :: IfaceExtName -> RdrName
318 ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ
319 ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
321 add_forall tv (HsForAllTy (Just tvs) cxt t) = HsForAllTy (Just (tv:tvs)) cxt t
322 add_forall tv t = HsForAllTy (Just [tv]) [] t
325 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l