import HsSyn
import RdrName
import OccName
-import Kind( Kind(..) )
-import Name( nameOccName, nameModule )
+import Type ( Kind,
+ liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
+ argTypeKindTyCon, ubxTupleKindTyCon, mkArrowKind, mkTyConApp
+ )
+import Name( Name, nameOccName, nameModule )
import Module
+import PackageConfig ( mainPackageId )
import ParserCoreUtils
import LexCore
import Literal
'%in' { TKin }
'%case' { TKcase }
'%of' { TKof }
- '%coerce' { TKcoerce }
+ '%cast' { TKcast }
'%note' { TKnote }
'%external' { TKexternal }
'%_' { TKwild }
: '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 }
modid :: { Module }
- : CNAME { mkModuleFS (mkFastString $1) }
+ : CNAME { mkModule mainPackageId -- ToDo: wrong
+ (mkModuleNameFS (mkFastString $1)) }
-------------------------------------------------------------
-- Type and newtype declarations are in HsSyn syntax
tdef :: { TyClDecl RdrName }
: '%data' q_tc_name tv_bndrs '=' '{' cons '}'
- { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) Nothing $6 Nothing }
+ { mkTyData DataType ( noLoc []
+ , noLoc (ifaceExtRdrName $2)
+ , map toHsTvBndr $3
+ , Nothing
+ ) Nothing $6 Nothing }
| '%newtype' q_tc_name tv_bndrs trep
{ let tc_rdr = ifaceExtRdrName $2 in
- mkTyData NewType (noLoc [], noLoc tc_rdr, map toHsTvBndr $3) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
+ mkTyData NewType ( noLoc []
+ , noLoc tc_rdr
+ , map toHsTvBndr $3
+ , Nothing
+ ) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
-- For a newtype we have to invent a fake data constructor name
-- It doesn't matter what it is, because it won't be used
| '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
con_info = PrefixCon [toHsType $2] }
in [noLoc $ ConDecl (noLoc dc_name) Explicit []
- (noLoc []) con_info ResTyH98]) }
+ (noLoc []) con_info ResTyH98 Nothing]) }
cons :: { [LConDecl RdrName] }
: {- empty -} { [] } -- 20060420 Empty data types allowed. jds
con :: { LConDecl RdrName }
: d_pat_occ attv_bndrs hs_atys
- { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98}
+ { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98 Nothing }
| d_pat_occ '::' ty
- -- XXX - autrijus - $3 needs to be split into argument and return types!
+ -- XXX - audreyt - $3 needs to be split into argument and return types!
-- also not sure whether the [] below (quantified vars) appears.
-- also the "PrefixCon []" is wrong.
-- also we want to munge $3 somehow.
-- extractWhatEver to unpack ty into the parts to ConDecl
-- XXX - define it somewhere in RdrHsSyn
- { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) }
+ { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) Nothing }
attv_bndrs :: { [LHsTyVarBndr RdrName] }
: {- empty -} { [] }
| id_bndr id_bndrs { $1:$2 }
tv_bndr :: { IfaceTvBndr }
- : tv_occ { ($1, LiftedTypeKind) }
+ : tv_occ { ($1, ifaceLiftedTypeKind) }
| '(' tv_occ '::' akind ')' { ($2, $4) }
tv_bndrs :: { [IfaceTvBndr] }
| tv_bndr tv_bndrs { $1:$2 }
akind :: { IfaceKind }
- : '*' { LiftedTypeKind }
- | '#' { UnliftedTypeKind }
- | '?' { OpenTypeKind }
+ : '*' { ifaceLiftedTypeKind }
+ | '#' { ifaceUnliftedTypeKind }
+ | '?' { ifaceOpenTypeKind }
| '(' kind ')' { $2 }
kind :: { IfaceKind }
: akind { $1 }
- | akind '->' kind { FunKind $1 $3 }
+ | akind '->' kind { ifaceArrow $1 $3 }
-----------------------------------------
-- Expressions
aexp :: { IfaceExpr }
: var_occ { IfaceLcl $1 }
- | modid '.' qd_occ { IfaceExt (ExtPkg $1 (mkVarOccFS $3)) }
+ | modid '.' qd_occ { IfaceExt undefined {-ToDo!!! (ExtPkg $1 (mkVarOccFS $3))-} }
| lit { IfaceLit $1 }
| '(' exp ')' { $2 }
-- gaw 2004
| '%case' '(' ty ')' aexp '%of' id_bndr
'{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 }
- | '%coerce' aty exp { IfaceNote (IfaceCoerce $2) $3 }
+ | '%cast' exp aty { IfaceCast $2 $3 }
| '%note' STRING exp
{ case $2 of
--"SCC" -> IfaceNote (IfaceSCC "scc") $3
alt :: { IfaceAlt }
: modid '.' d_pat_occ bndrs '->' exp
- { (IfaceDataAlt $3, map ifaceBndrName $4, $6) }
+ { (IfaceDataAlt undefined {-ToDo!!! $3 -}, map ifaceBndrName $4, $6) }
-- The external syntax currently includes the types of the
-- the args, but they aren't needed internally
-- Nor is the module qualifier
-- Type constructor
-q_tc_name :: { IfaceExtName }
- : modid '.' CNAME { ExtPkg $1 (mkOccName tcName $3) }
+q_tc_name :: { Name }
+ : modid '.' CNAME { undefined {-ToDo!!! ExtPkg $1 (mkOccName tcName $3)-} }
-- Data constructor in a pattern or data type declaration; use the dataName,
-- because that's what we expect in Core case patterns
{
+ifaceKind kc = IfaceTyConApp kc []
+
ifaceBndrName (IfaceIdBndr (n,_)) = n
ifaceBndrName (IfaceTvBndr (n,_)) = n
= pprPanic "Unknown rational literal type" (ppr aty)
eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh!
-eqTc (IfaceTc (ExtPkg mod occ)) tycon
- = mod == nameModule nm && occ == nameOccName nm
- where
- nm = tyConName tycon
+eqTc (IfaceTc name) tycon = name == tyConName tycon
-- Tiresomely, we have to generate both HsTypes (in type/class decls)
-- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes,
toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts)
toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t)
+-- We also need to convert IfaceKinds to Kinds (now that they are different).
+-- Only a limited form of kind will be encountered... hopefully
+toKind :: IfaceKind -> Kind
+toKind (IfaceFunTy ifK1 ifK2) = mkArrowKind (toKind ifK1) (toKind ifK2)
+toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) []
+toKind other = pprPanic "toKind" (ppr other)
+
+toKindTc :: IfaceTyCon -> TyCon
+toKindTc IfaceLiftedTypeKindTc = liftedTypeKindTyCon
+toKindTc IfaceOpenTypeKindTc = openTypeKindTyCon
+toKindTc IfaceUnliftedTypeKindTc = unliftedTypeKindTyCon
+toKindTc IfaceUbxTupleKindTc = ubxTupleKindTyCon
+toKindTc IfaceArgTypeKindTc = argTypeKindTyCon
+toKindTc other = pprPanic "toKindTc" (ppr other)
+
+ifaceTcType ifTc = IfaceTyConApp ifTc []
+
+ifaceLiftedTypeKind = ifaceTcType IfaceLiftedTypeKindTc
+ifaceOpenTypeKind = ifaceTcType IfaceOpenTypeKindTc
+ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc
+
+ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
+
toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) k
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) (toKind k)
-ifaceExtRdrName :: IfaceExtName -> RdrName
-ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ
+ifaceExtRdrName :: Name -> RdrName
+ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
add_forall tv (L _ (HsForAllTy exp tvs cxt t))