2 {-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
3 {-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-}
4 -- The NoMonomorphismRestriction deals with a Happy infelicity
5 -- With OutsideIn's more conservativ monomorphism restriction
6 -- we aren't generalising
7 -- notHappyAtAll = error "urk"
8 -- which is terrible. Switching off the restriction allows
9 -- the generalisation. Better would be to make Happy generate
10 -- an appropriate signature.
12 -- The above warning supression flag is a temporary kludge.
13 -- While working on this module you are encouraged to remove it and fix
14 -- any warnings in the module. See
15 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
18 module ParserCore ( parseCore ) where
27 liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
28 argTypeKindTyCon, ubxTupleKindTyCon, mkTyConApp
30 import Coercion( mkArrowKind )
31 import Name( Name, nameOccName, nameModule, mkExternalName )
33 import ParserCoreUtils
37 import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon,
38 floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
39 import TyCon ( TyCon, tyConName )
45 #include "../HsVersions.h"
54 '%module' { TKmodule }
56 '%newtype' { TKnewtype }
57 '%forall' { TKforall }
65 '%external' { TKexternal }
76 ':=:' { TKcoloneqcolon }
86 INTEGER { TKinteger $$ }
87 RATIONAL { TKrational $$ }
88 STRING { TKstring $$ }
91 %monad { P } { thenP } { returnP }
92 %lexer { lexer } { TKEOF }
96 module :: { HsExtCore RdrName }
97 -- : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 }
98 : '%module' modid tdefs vdefgs { HsExtCore $2 [] [] }
101 -------------------------------------------------------------
102 -- Names: the trickiest bit in here
104 -- A name of the form A.B.C could be:
106 -- dcon C in module A.B
107 -- tcon C in module A.B
109 : NAME ':' mparts { undefined }
111 q_dc_name :: { Name }
112 : NAME ':' mparts { undefined }
114 q_tc_name :: { Name }
115 : NAME ':' mparts { undefined }
117 q_var_occ :: { Name }
118 : NAME ':' vparts { undefined }
120 mparts :: { [String] }
122 | CNAME '.' mparts { $1:$3 }
124 vparts :: { [String] }
126 | CNAME '.' vparts { $1:$3 }
128 -------------------------------------------------------------
129 -- Type and newtype declarations are in HsSyn syntax
131 tdefs :: { [TyClDecl RdrName] }
135 tdef :: { TyClDecl RdrName }
136 : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
137 { TyData { tcdND = DataType, tcdCtxt = noLoc []
138 , tcdLName = noLoc (ifaceExtRdrName $2)
139 , tcdTyVars = map toHsTvBndr $3
140 , tcdTyPats = Nothing, tcdKindSig = Nothing
141 , tcdCons = $6, tcdDerivs = Nothing } }
142 | '%newtype' q_tc_name tv_bndrs trep ';'
143 { let tc_rdr = ifaceExtRdrName $2 in
144 TyData { tcdND = NewType, tcdCtxt = noLoc []
145 , tcdLName = noLoc tc_rdr
146 , tcdTyVars = map toHsTvBndr $3
147 , tcdTyPats = Nothing, tcdKindSig = Nothing
148 , tcdCons = $4 (rdrNameOcc tc_rdr), tcdDerivs = Nothing } }
150 -- For a newtype we have to invent a fake data constructor name
151 -- It doesn't matter what it is, because it won't be used
152 trep :: { OccName -> [LConDecl RdrName] }
153 : {- empty -} { (\ tc_occ -> []) }
154 | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
155 con_info = PrefixCon [toHsType $2] }
156 in [noLoc $ mkSimpleConDecl (noLoc dc_name) []
157 (noLoc []) con_info]) }
159 cons :: { [LConDecl RdrName] }
160 : {- empty -} { [] } -- 20060420 Empty data types allowed. jds
162 | con ';' cons { $1:$3 }
164 con :: { LConDecl RdrName }
165 : d_pat_occ attv_bndrs hs_atys
166 { noLoc $ mkSimpleConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3) }
167 -- ToDo: parse record-style declarations
169 attv_bndrs :: { [LHsTyVarBndr RdrName] }
171 | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 }
173 hs_atys :: { [LHsType RdrName] }
174 : atys { map toHsType $1 }
177 ---------------------------------------
179 ---------------------------------------
181 atys :: { [IfaceType] }
186 : fs_var_occ { IfaceTyVar $1 }
187 | q_tc_name { IfaceTyConApp (IfaceTc $1) [] }
191 : fs_var_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 }
192 | q_var_occ atys { undefined }
193 | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 }
198 | bty '->' ty { IfaceFunTy $1 $3 }
199 | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 }
201 ----------------------------------------------
202 -- Bindings are in Iface syntax
204 vdefgs :: { [IfaceBinding] }
206 | let_bind ';' vdefgs { $1 : $3 }
208 let_bind :: { IfaceBinding }
209 : '%rec' '{' vdefs1 '}' { IfaceRec $3 } -- Can be empty. Do we care?
210 | vdef { let (b,r) = $1
213 vdefs1 :: { [(IfaceLetBndr, IfaceExpr)] }
215 | vdef ';' vdefs1 { $1:$3 }
217 vdef :: { (IfaceLetBndr, IfaceExpr) }
218 : fs_var_occ '::' ty '=' exp { (IfLetBndr $1 $3 NoInfo, $5) }
219 | '%local' vdef { $2 }
221 -- NB: qd_occ includes data constructors, because
222 -- we allow data-constructor wrappers at top level
223 -- But we discard the module name, because it must be the
224 -- same as the module being compiled, and Iface syntax only
225 -- has OccNames in binding positions. Ah, but it has Names now!
227 ---------------------------------------
229 bndr :: { IfaceBndr }
230 : '@' tv_bndr { IfaceTvBndr $2 }
231 | id_bndr { IfaceIdBndr $1 }
233 bndrs :: { [IfaceBndr] }
235 | bndr bndrs { $1:$2 }
237 id_bndr :: { IfaceIdBndr }
238 : '(' fs_var_occ '::' ty ')' { ($2,$4) }
240 tv_bndr :: { IfaceTvBndr }
241 : fs_var_occ { ($1, ifaceLiftedTypeKind) }
242 | '(' fs_var_occ '::' akind ')' { ($2, $4) }
244 tv_bndrs :: { [IfaceTvBndr] }
246 | tv_bndr tv_bndrs { $1:$2 }
248 akind :: { IfaceKind }
249 : '*' { ifaceLiftedTypeKind }
250 | '#' { ifaceUnliftedTypeKind }
251 | '?' { ifaceOpenTypeKind }
252 | '(' kind ')' { $2 }
254 kind :: { IfaceKind }
256 | akind '->' kind { ifaceArrow $1 $3 }
257 | ty ':=:' ty { ifaceEq $1 $3 }
259 -----------------------------------------
262 aexp :: { IfaceExpr }
263 : fs_var_occ { IfaceLcl $1 }
264 | q_var_occ { IfaceExt $1 }
265 | q_dc_name { IfaceExt $1 }
266 | lit { IfaceLit $1 }
269 fexp :: { IfaceExpr }
270 : fexp aexp { IfaceApp $1 $2 }
271 | fexp '@' aty { IfaceApp $1 (IfaceType $3) }
276 | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 }
277 | '%let' let_bind '%in' exp { IfaceLet $2 $4 }
279 | '%case' '(' ty ')' aexp '%of' id_bndr
280 '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 }
281 | '%cast' aexp aty { IfaceCast $2 $3 }
282 -- No InlineMe any more
283 -- | '%note' STRING exp
285 -- --"SCC" -> IfaceNote (IfaceSCC "scc") $3
286 -- "InlineMe" -> IfaceNote IfaceInlineMe $3
288 | '%external' STRING aty { IfaceFCall (ForeignCall.CCall
289 (CCallSpec (StaticTarget (mkFastString $2) Nothing)
290 CCallConv (PlaySafe False)))
293 alts1 :: { [IfaceAlt] }
295 | alt ';' alts1 { $1:$3 }
298 : q_dc_name bndrs '->' exp
299 { (IfaceDataAlt $1, map ifaceBndrName $2, $4) }
300 -- The external syntax currently includes the types of the
301 -- the args, but they aren't needed internally
302 -- Nor is the module qualifier
304 { (IfaceDataAlt $1, [], $3) }
306 { (IfaceLitAlt $1, [], $3) }
308 { (IfaceDefault, [], $3) }
311 : '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
312 | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
313 | '(' CHAR '::' aty ')' { MachChar $2 }
314 | '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
316 fs_var_occ :: { FastString }
317 : NAME { mkFastString $1 }
319 var_occ :: { String }
323 -- Data constructor in a pattern or data type declaration; use the dataName,
324 -- because that's what we expect in Core case patterns
325 d_pat_occ :: { OccName }
326 : CNAME { mkOccName dataName $1 }
330 ifaceKind kc = IfaceTyConApp kc []
332 ifaceBndrName (IfaceIdBndr (n,_)) = n
333 ifaceBndrName (IfaceTvBndr (n,_)) = n
335 convIntLit :: Integer -> IfaceType -> Literal
336 convIntLit i (IfaceTyConApp tc [])
337 | tc `eqTc` intPrimTyCon = MachInt i
338 | tc `eqTc` wordPrimTyCon = MachWord i
339 | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i))
340 | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr
342 = pprPanic "Unknown integer literal type" (ppr aty)
344 convRatLit :: Rational -> IfaceType -> Literal
345 convRatLit r (IfaceTyConApp tc [])
346 | tc `eqTc` floatPrimTyCon = MachFloat r
347 | tc `eqTc` doublePrimTyCon = MachDouble r
349 = pprPanic "Unknown rational literal type" (ppr aty)
351 eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh!
352 eqTc (IfaceTc name) tycon = name == tyConName tycon
354 -- Tiresomely, we have to generate both HsTypes (in type/class decls)
355 -- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes,
356 -- and convert to HsTypes here. But the IfaceTypes we can see here
357 -- are very limited (see the productions for 'ty', so the translation
359 toHsType :: IfaceType -> LHsType RdrName
360 toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOccFS v))
361 toHsType (IfaceAppTy t1 t2) = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
362 toHsType (IfaceFunTy t1 t2) = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
363 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts)
364 toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t)
366 -- We also need to convert IfaceKinds to Kinds (now that they are different).
367 -- Only a limited form of kind will be encountered... hopefully
368 toKind :: IfaceKind -> Kind
369 toKind (IfaceFunTy ifK1 ifK2) = mkArrowKind (toKind ifK1) (toKind ifK2)
370 toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) []
371 toKind other = pprPanic "toKind" (ppr other)
373 toKindTc :: IfaceTyCon -> TyCon
374 toKindTc IfaceLiftedTypeKindTc = liftedTypeKindTyCon
375 toKindTc IfaceOpenTypeKindTc = openTypeKindTyCon
376 toKindTc IfaceUnliftedTypeKindTc = unliftedTypeKindTyCon
377 toKindTc IfaceUbxTupleKindTc = ubxTupleKindTyCon
378 toKindTc IfaceArgTypeKindTc = argTypeKindTyCon
379 toKindTc other = pprPanic "toKindTc" (ppr other)
381 ifaceTcType ifTc = IfaceTyConApp ifTc []
383 ifaceLiftedTypeKind = ifaceTcType IfaceLiftedTypeKindTc
384 ifaceOpenTypeKind = ifaceTcType IfaceOpenTypeKindTc
385 ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc
387 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
389 ifaceEq ifT1 ifT2 = IfacePredTy (IfaceEqPred ifT1 ifT2)
391 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
392 toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toKind k)
394 ifaceExtRdrName :: Name -> RdrName
395 ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
396 ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
398 add_forall tv (L _ (HsForAllTy exp tvs cxt t))
399 = noLoc $ HsForAllTy exp (tv:tvs) cxt t
401 = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
404 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l