X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParserCore.y;h=3210583f9651cfa70247dadca7adafb2fa17fd42;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=c18a15a99aa6788d80579073e93dd2207a211d1b;hpb=a7def5990194fa889349de4035b6cd4dfed1c57b;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index c18a15a..3210583 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -1,21 +1,25 @@ { module ParserCore ( parseCore ) where -import HsCore +import IfaceSyn +import ForeignCall import RdrHsSyn import HsSyn -import TyCon -import TcType import RdrName import OccName +import Kind( Kind(..) ) +import Name( nameOccName, nameModule ) import Module import ParserCoreUtils import LexCore import Literal -import BasicTypes -import Type import SrcLoc +import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, + floatPrimTyCon, doublePrimTyCon, addrPrimTyCon ) +import TyCon ( TyCon, tyConName ) import FastString +import Outputable +import Char #include "../HsVersions.h" @@ -64,185 +68,271 @@ import FastString %% -module :: { RdrNameHsModule } - : '%module' modid tdefs vdefgs - { HsModule $2 Nothing Nothing [] ($3 ++ concat $4) Nothing noSrcLoc} +module :: { HsExtCore RdrName } + : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 } -tdefs :: { [RdrNameHsDecl] } +modid :: { Module } + : CNAME { mkModuleFS (mkFastString $1) } + +------------------------------------------------------------- +-- Type and newtype declarations are in HsSyn syntax + +tdefs :: { [TyClDecl RdrName] } : {- empty -} {[]} | tdef ';' tdefs {$1:$3} -tdef :: { RdrNameHsDecl } - : '%data' q_tc_name tbinds '=' '{' cons1 '}' - { TyClD (TyData DataType [] $2 $3 (DataCons $6) Nothing [] noSrcLoc) } - | '%newtype' q_tc_name tbinds trep - { TyClD (TyData NewType [] $2 $3 ($4 $2 $3) Nothing [] noSrcLoc) } +tdef :: { TyClDecl RdrName } + : '%data' q_tc_name tv_bndrs '=' '{' cons1 '}' + { mkTyData DataType (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 (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 -> [LConDecl RdrName] } + : {- empty -} { (\ tc_occ -> []) } + | '=' 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]) } + +cons1 :: { [LConDecl RdrName] } + : con { [$1] } + | con ';' cons1 { $1:$3 } -trep :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) } - : {- empty -} { (\ x ts -> Unknown) } - | '=' ty { (\ x ts -> DataCons [ConDecl x x ts [] (VanillaCon [unbangedType $2]) noSrcLoc]) } +con :: { LConDecl RdrName } + : d_pat_occ attv_bndrs hs_atys + { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98} + | d_pat_occ '::' ty + -- XXX - autrijus - $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) } -tbind :: { HsTyVarBndr RdrName } - : name { IfaceTyVar $1 liftedTypeKind } - | '(' name '::' akind ')' { IfaceTyVar $2 $4 } +attv_bndrs :: { [LHsTyVarBndr RdrName] } + : {- empty -} { [] } + | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 } -tbinds :: { [HsTyVarBndr RdrName] } - : {- empty -} { [] } - | tbind tbinds { $1:$2 } +hs_atys :: { [LHsType RdrName] } + : atys { map toHsType $1 } -vdefgs :: { [[RdrNameHsDecl]] } - : {- empty -} { [] } - | vdefg ';' vdefgs { ($1:$3) } -vdefg :: { [RdrNameHsDecl] } - : '%rec' '{' vdefs1 '}' { $3 } - | vdef { [$1] } +--------------------------------------- +-- Types +--------------------------------------- -let_bind :: { UfBinding RdrName } - : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3) } - | vdef { let (b,r) = convBind $1 - in UfNonRec b r } +atys :: { [IfaceType] } + : {- empty -} { [] } + | aty atys { $1:$2 } -vdefs1 :: { [RdrNameHsDecl] } - : vdef { [$1] } - | vdef ';' vdefs1 { $1:$3 } +aty :: { IfaceType } + : tv_occ { IfaceTyVar $1 } + | q_tc_name { IfaceTyConApp (IfaceTc $1) [] } + | '(' ty ')' { $2 } + +bty :: { IfaceType } + : tv_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 } + | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 } + | '(' ty ')' { $2 } -vdef :: { RdrNameHsDecl } - : qname '::' ty '=' exp { TyClD (CoreDecl $1 $3 $5 noSrcLoc) } +ty :: { IfaceType } + : bty { $1 } + | bty '->' ty { IfaceFunTy $1 $3 } + | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 } +---------------------------------------------- +-- Bindings are in Iface syntax -vbind :: { (RdrName, RdrNameHsType) } - : '(' name '::' ty ')' { ($2,$4) } +vdefgs :: { [IfaceBinding] } + : {- empty -} { [] } + | let_bind ';' vdefgs { $1 : $3 } -vbinds :: { [(RdrName, RdrNameHsType)] } - : {-empty -} { [] } - | vbind vbinds { $1:$2 } +let_bind :: { IfaceBinding } + : '%rec' '{' vdefs1 '}' { IfaceRec $3 } + | vdef { let (b,r) = $1 + in IfaceNonRec b r } -bind :: { UfBinder RdrName } - : '@' tbind { let (IfaceTyVar v k) = $2 in UfTyBinder v k } - | vbind { let (v,ty) = $1 in UfValBinder v ty } +vdefs1 :: { [(IfaceIdBndr, IfaceExpr)] } + : vdef { [$1] } + | vdef ';' vdefs1 { $1:$3 } -binds1 :: { [UfBinder RdrName] } - : bind { [$1] } - | bind binds1 { $1:$2 } +vdef :: { (IfaceIdBndr, IfaceExpr) } + : qd_occ '::' ty '=' exp { (($1, $3), $5) } + -- NB: qd_occ includes data constructors, because + -- we allow data-constructor wrappers at top level + -- But we discard the module name, because it must be the + -- same as the module being compiled, and Iface syntax only + -- has OccNames in binding positions -attbinds :: { [RdrNameHsTyVar] } - : {- empty -} { [] } - | '@' tbind attbinds { $2:$3 } +qd_occ :: { OccName } + : var_occ { $1 } + | d_occ { $1 } -akind :: { Kind } - : '*' { liftedTypeKind } - | '#' { unliftedTypeKind } - | '?' { openTypeKind } - | '(' kind ')' { $2 } +--------------------------------------- +-- Binders +bndr :: { IfaceBndr } + : '@' tv_bndr { IfaceTvBndr $2 } + | id_bndr { IfaceIdBndr $1 } -kind :: { Kind } - : akind { $1 } - | akind '->' kind { mkArrowKind $1 $3 } +bndrs :: { [IfaceBndr] } + : bndr { [$1] } + | bndr bndrs { $1:$2 } -cons1 :: { [ConDecl RdrName] } - : con { [$1] } - | con ';' cons1 { $1:$3 } +id_bndr :: { IfaceIdBndr } + : '(' var_occ '::' ty ')' { ($2,$4) } -con :: { ConDecl RdrName } - : q_d_name attbinds atys - { ConDecl $1 $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc} +id_bndrs :: { [IfaceIdBndr] } + : {-empty -} { [] } + | id_bndr id_bndrs { $1:$2 } -atys :: { [ RdrNameHsType] } - : {- empty -} { [] } - | aty atys { $1:$2 } +tv_bndr :: { IfaceTvBndr } + : tv_occ { ($1, LiftedTypeKind) } + | '(' tv_occ '::' akind ')' { ($2, $4) } -aty :: { RdrNameHsType } - : name { HsTyVar $1 } - | q_tc_name { HsTyVar $1 } - | '(' ty ')' { $2 } +tv_bndrs :: { [IfaceTvBndr] } + : {- empty -} { [] } + | tv_bndr tv_bndrs { $1:$2 } +akind :: { IfaceKind } + : '*' { LiftedTypeKind } + | '#' { UnliftedTypeKind } + | '?' { OpenTypeKind } + | '(' kind ')' { $2 } -bty :: { RdrNameHsType } - : aty { $1 } - | bty aty { HsAppTy $1 $2 } +kind :: { IfaceKind } + : akind { $1 } + | akind '->' kind { FunKind $1 $3 } -ty :: { RdrNameHsType } - : bty { $1 } - | bty '->' ty { HsFunTy $1 $3 } - | '%forall' tbinds '.' ty { HsForAllTy (Just $2) [] $4 } +----------------------------------------- +-- Expressions -aexp :: { UfExpr RdrName } - : qname { UfVar $1 } - | q_d_name { UfVar $1 } - | lit { UfLit $1 } +aexp :: { IfaceExpr } + : var_occ { IfaceLcl $1 } + | modid '.' qd_occ { IfaceExt (ExtPkg $1 $3) } + | lit { IfaceLit $1 } | '(' exp ')' { $2 } -fexp :: { UfExpr RdrName } - : fexp aexp { UfApp $1 $2 } - | fexp '@' aty { UfApp $1 (UfType $3) } +fexp :: { IfaceExpr } + : fexp aexp { IfaceApp $1 $2 } + | fexp '@' aty { IfaceApp $1 (IfaceType $3) } | aexp { $1 } -exp :: { UfExpr RdrName } - : fexp { $1 } - | '\\' binds1 '->' exp { foldr UfLam $4 $2 } - | '%let' let_bind '%in' exp { UfLet $2 $4 } - | '%case' aexp '%of' vbind - '{' alts1 '}' { UfCase $2 (fst $4) $6 } - | '%coerce' aty exp { UfNote (UfCoerce $2) $3 } -- what about the 'from' type? +exp :: { IfaceExpr } + : fexp { $1 } + | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 } + | '%let' let_bind '%in' exp { IfaceLet $2 $4 } +-- 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 - --"SCC" -> UfNote (UfSCC "scc") $3 - "InlineCall" -> UfNote UfInlineCall $3 - "InlineMe" -> UfNote UfInlineMe $3 + --"SCC" -> IfaceNote (IfaceSCC "scc") $3 + "InlineCall" -> IfaceNote IfaceInlineCall $3 + "InlineMe" -> IfaceNote IfaceInlineMe $3 } --- | '%external' STRING aty { External $2 $3 } + | '%external' STRING aty { IfaceFCall (ForeignCall.CCall + (CCallSpec (StaticTarget (mkFastString $2)) + CCallConv (PlaySafe False))) + $3 } -alts1 :: { [UfAlt RdrName] } +alts1 :: { [IfaceAlt] } : alt { [$1] } | alt ';' alts1 { $1:$3 } -alt :: { UfAlt RdrName } - : q_d_name attbinds vbinds '->' exp - { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) } +alt :: { IfaceAlt } + : modid '.' d_pat_occ bndrs '->' exp + { (IfaceDataAlt $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 | lit '->' exp - { (UfLitAlt $1, [], $3) } + { (IfaceLitAlt $1, [], $3) } | '%_' '->' exp - { (UfDefault, [], $3) } + { (IfaceDefault, [], $3) } lit :: { Literal } - : '(' INTEGER '::' aty ')' { MachInt $2 } - | '(' RATIONAL '::' aty ')' { MachDouble $2 } - | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) } + : '(' INTEGER '::' aty ')' { convIntLit $2 $4 } + | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 } + | '(' CHAR '::' aty ')' { MachChar $2 } | '(' STRING '::' aty ')' { MachStr (mkFastString $2) } -name :: { RdrName } - : NAME { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) } - -cname :: { String } - : CNAME { $1 } - -mname :: { String } - : CNAME { $1 } +tv_occ :: { OccName } + : NAME { mkOccName tvName $1 } -modid :: { ModuleName } - : CNAME { mkSysModuleNameFS (mkFastString $1) } +var_occ :: { OccName } + : NAME { mkVarOcc $1 } -qname :: { RdrName } - : name { $1 } - | mname '.' NAME - { mkIfaceOrig varName (mkFastString $1,mkFastString $3) } -- Type constructor -q_tc_name :: { RdrName } - : mname '.' cname - { mkIfaceOrig tcName (mkFastString $1,mkFastString $3) } +q_tc_name :: { IfaceExtName } + : modid '.' CNAME { ExtPkg $1 (mkOccName tcName $3) } --- Data constructor -q_d_name :: { RdrName } - : mname '.' cname - { mkIfaceOrig dataName (mkFastString $1,mkFastString $3) } +-- Data constructor in a pattern or data type declaration; use the dataName, +-- because that's what we expect in Core case patterns +d_pat_occ :: { OccName } + : CNAME { mkOccName dataName $1 } +-- Data constructor occurrence in an expression; +-- use the varName because that's the worker Id +d_occ :: { OccName } + : CNAME { mkVarOcc $1 } { -convBind :: RdrNameHsDecl -> (UfBinder RdrName, UfExpr RdrName) -convBind (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs) +ifaceBndrName (IfaceIdBndr (n,_)) = n +ifaceBndrName (IfaceTvBndr (n,_)) = n + +convIntLit :: Integer -> IfaceType -> Literal +convIntLit i (IfaceTyConApp tc []) + | tc `eqTc` intPrimTyCon = MachInt i + | tc `eqTc` wordPrimTyCon = MachWord i + | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i)) + | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr +convIntLit i aty + = pprPanic "Unknown integer literal type" (ppr aty) + +convRatLit :: Rational -> IfaceType -> Literal +convRatLit r (IfaceTyConApp tc []) + | tc `eqTc` floatPrimTyCon = MachFloat r + | tc `eqTc` doublePrimTyCon = MachDouble r +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 + +-- Tiresomely, we have to generate both HsTypes (in type/class decls) +-- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes, +-- 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 -> 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 -> 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 (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 }