X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParserCore.y;h=33f4aad3ac6c4512a74b502e9b975a88016a0da3;hb=d04c4288dfc76c3cc593a37824bf2e996663abfb;hp=4f025f9c0fce3db8f415454e8b42feff9389472f;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index 4f025f9..33f4aad 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -4,22 +4,22 @@ module ParserCore ( parseCore ) where import IfaceSyn import ForeignCall import RdrHsSyn -import TcIface ( tcIfaceKind ) import HsSyn import RdrName import OccName -import Name( nameOccName, nameModuleName ) +import Kind( Kind(..) ) +import Name( nameOccName, nameModule ) import Module import ParserCoreUtils import LexCore import Literal -import BasicTypes import SrcLoc import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, floatPrimTyCon, doublePrimTyCon, addrPrimTyCon ) import TyCon ( TyCon, tyConName ) import FastString import Outputable +import Char #include "../HsVersions.h" @@ -69,11 +69,10 @@ import Outputable %% module :: { HsExtCore RdrName } - : '%module' modid tdefs vdefgs - { HsExtCore (mkHomeModule $2) $3 $4 } + : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 } -modid :: { ModuleName } - : CNAME { mkSysModuleNameFS (mkFastString $1) } +modid :: { Module } + : CNAME { mkSysModuleFS (mkFastString $1) } ------------------------------------------------------------- -- Type and newtype declarations are in HsSyn syntax @@ -84,32 +83,35 @@ tdefs :: { [TyClDecl RdrName] } tdef :: { TyClDecl RdrName } : '%data' q_tc_name tv_bndrs '=' '{' cons1 '}' - { mkTyData DataType ([], ifaceExtRdrName $2, map toHsTvBndr $3) $6 Nothing noSrcLoc } + { mkTyData DataType (noLoc (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3)) Nothing $6 Nothing } | '%newtype' q_tc_name tv_bndrs trep { let tc_rdr = ifaceExtRdrName $2 in - mkTyData NewType ([], tc_rdr, map toHsTvBndr $3) ($4 (rdrNameOcc tc_rdr)) Nothing noSrcLoc } + mkTyData NewType (noLoc (noLoc [], noLoc tc_rdr, map toHsTvBndr $3)) 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 -trep :: { OccName -> [ConDecl RdrName] } +trep :: { OccName -> [LConDecl RdrName] } : {- empty -} { (\ tc_occ -> []) } | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ; - con_info = PrefixCon [unbangedType (toHsType $2)] } - in [ConDecl dc_name [] [] con_info noSrcLoc]) } + con_info = PrefixCon [toHsType $2] } + in [noLoc $ ConDecl (noLoc dc_name) [] + (noLoc []) con_info]) } -cons1 :: { [ConDecl RdrName] } +cons1 :: { [LConDecl RdrName] } : con { [$1] } | con ';' cons1 { $1:$3 } -con :: { ConDecl RdrName } +con :: { LConDecl RdrName } : d_pat_occ attv_bndrs hs_atys - { ConDecl (mkRdrUnqual $1) $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc} + { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3)} + | d_pat_occ '::' ty + { noLoc $ GadtDecl (noLoc (mkRdrUnqual $1)) (toHsType $3) } -attv_bndrs :: { [HsTyVarBndr RdrName] } +attv_bndrs :: { [LHsTyVarBndr RdrName] } : {- empty -} { [] } | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 } -hs_atys :: { [HsType RdrName] } +hs_atys :: { [LHsType RdrName] } : atys { map toHsType $1 } @@ -181,7 +183,7 @@ id_bndrs :: { [IfaceIdBndr] } | id_bndr id_bndrs { $1:$2 } tv_bndr :: { IfaceTvBndr } - : tv_occ { ($1, IfaceLiftedTypeKind) } + : tv_occ { ($1, LiftedTypeKind) } | '(' tv_occ '::' akind ')' { ($2, $4) } tv_bndrs :: { [IfaceTvBndr] } @@ -189,14 +191,14 @@ tv_bndrs :: { [IfaceTvBndr] } | tv_bndr tv_bndrs { $1:$2 } akind :: { IfaceKind } - : '*' { IfaceLiftedTypeKind } - | '#' { IfaceUnliftedTypeKind } - | '?' { IfaceOpenTypeKind } + : '*' { LiftedTypeKind } + | '#' { UnliftedTypeKind } + | '?' { OpenTypeKind } | '(' kind ')' { $2 } kind :: { IfaceKind } : akind { $1 } - | akind '->' kind { IfaceFunKind $1 $3 } + | akind '->' kind { FunKind $1 $3 } ----------------------------------------- -- Expressions @@ -216,8 +218,9 @@ exp :: { IfaceExpr } : fexp { $1 } | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 } | '%let' let_bind '%in' exp { IfaceLet $2 $4 } - | '%case' aexp '%of' id_bndr - '{' alts1 '}' { IfaceCase $2 (fst $4) $6 } +-- gaw 2004 + | '%case' '(' ty ')' aexp '%of' id_bndr + '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 } | '%coerce' aty exp { IfaceNote (IfaceCoerce $2) $3 } | '%note' STRING exp { case $2 of @@ -248,7 +251,7 @@ alt :: { IfaceAlt } lit :: { Literal } : '(' INTEGER '::' aty ')' { convIntLit $2 $4 } | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 } - | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) } + | '(' CHAR '::' aty ')' { MachChar $2 } | '(' STRING '::' aty ')' { MachStr (mkFastString $2) } tv_occ :: { OccName } @@ -281,7 +284,7 @@ convIntLit :: Integer -> IfaceType -> Literal convIntLit i (IfaceTyConApp tc []) | tc `eqTc` intPrimTyCon = MachInt i | tc `eqTc` wordPrimTyCon = MachWord i - | tc `eqTc` charPrimTyCon = MachChar (fromInteger i) + | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i)) | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr convIntLit i aty = pprPanic "Unknown integer literal type" (ppr aty) @@ -295,7 +298,7 @@ convRatLit i aty eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh! eqTc (IfaceTc (ExtPkg mod occ)) tycon - = mod == nameModuleName nm && occ == nameOccName nm + = mod == nameModule nm && occ == nameOccName nm where nm = tyConName tycon @@ -304,22 +307,24 @@ eqTc (IfaceTc (ExtPkg mod occ)) tycon -- and convert to HsTypes here. But the IfaceTypes we can see here -- are very limited (see the productions for 'ty', so the translation -- isn't hard -toHsType :: IfaceType -> HsType RdrName -toHsType (IfaceTyVar v) = HsTyVar (mkRdrUnqual v) -toHsType (IfaceAppTy t1 t2) = HsAppTy (toHsType t1) (toHsType t2) -toHsType (IfaceFunTy t1 t2) = HsFunTy (toHsType t1) (toHsType t2) -toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl HsAppTy (HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) +toHsType :: IfaceType -> LHsType RdrName +toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual v) +toHsType (IfaceAppTy t1 t2) = noLoc $ HsAppTy (toHsType t1) (toHsType t2) +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) -toHsTvBndr :: IfaceTvBndr -> HsTyVarBndr RdrName -toHsTvBndr (tv,k) = KindedTyVar (mkRdrUnqual tv) (tcIfaceKind k) +toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName +toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual tv) k ifaceExtRdrName :: IfaceExtName -> RdrName ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other) -add_forall tv (HsForAllTy (Just tvs) cxt t) = HsForAllTy (Just (tv:tvs)) cxt t -add_forall tv t = HsForAllTy (Just [tv]) [] t +add_forall tv (L _ (HsForAllTy exp tvs cxt t)) + = noLoc $ HsForAllTy exp (tv:tvs) cxt t +add_forall tv t + = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t happyError :: P a happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l