X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParserCore.y;h=b37add305ea69546670a5c045ba3306395536a21;hb=b88025eabcd83f65d1d81f09272f5172f06a60e7;hp=f2d48da7b61aca937ccff9e599801f4cd603b405;hpb=795c86daa4afb53f7ec99f5082e2e7fcc690830c;p=ghc-hetmet.git diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index f2d48da..b37add3 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -7,8 +7,11 @@ import RdrHsSyn 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 @@ -39,7 +42,7 @@ import Char '%in' { TKin } '%case' { TKcase } '%of' { TKof } - '%coerce' { TKcoerce } + '%cast' { TKcast } '%note' { TKnote } '%external' { TKexternal } '%_' { TKwild } @@ -85,10 +88,18 @@ tdefs :: { [TyClDecl RdrName] } 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 @@ -97,7 +108,7 @@ trep :: { OccName -> [LConDecl RdrName] } | '=' 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 @@ -105,7 +116,7 @@ cons :: { [LConDecl RdrName] } 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 - audreyt - $3 needs to be split into argument and return types! -- also not sure whether the [] below (quantified vars) appears. @@ -113,7 +124,7 @@ con :: { LConDecl RdrName } -- 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 -} { [] } @@ -192,7 +203,7 @@ id_bndrs :: { [IfaceIdBndr] } | 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] } @@ -200,21 +211,21 @@ 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 } @@ -230,7 +241,7 @@ exp :: { IfaceExpr } -- 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 @@ -247,7 +258,7 @@ alts1 :: { [IfaceAlt] } 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 @@ -270,8 +281,8 @@ var_occ :: { FastString } -- 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 @@ -285,6 +296,8 @@ d_occ :: { FastString } { +ifaceKind kc = IfaceTyConApp kc [] + ifaceBndrName (IfaceIdBndr (n,_)) = n ifaceBndrName (IfaceTvBndr (n,_)) = n @@ -305,10 +318,7 @@ convRatLit i aty = 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, @@ -322,11 +332,34 @@ toHsType (IfaceFunTy t1 t2) = noLoc $ HsFunTy (toHsType t1) (toHsType t2) 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))