X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParserCore.y;h=1cd7d6a6bf66f627d4558ff094cd3a3a37d548d9;hb=d28ba8c800901bea01f70c4719278c2a364cf9fc;hp=1039f8baf7915355b52982325ea8b26ae474fa27;hpb=acc784b55045fe43b2d92efc992a4b888d96c682;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index 1039f8b..1cd7d6a 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -15,6 +15,9 @@ import Literal import BasicTypes import Type import SrcLoc +import PrelNames +import FastString +import Outputable #include "../HsVersions.h" @@ -65,21 +68,26 @@ import SrcLoc module :: { RdrNameHsModule } : '%module' modid tdefs vdefgs - { HsModule $2 Nothing Nothing [] ($3 ++ concat $4) Nothing noSrcLoc} + { HsModule (Just (mkHomeModule $2)) Nothing + [] ($3 ++ concat $4) Nothing noSrcLoc} tdefs :: { [RdrNameHsDecl] } : {- empty -} {[]} | tdef ';' tdefs {$1:$3} tdef :: { RdrNameHsDecl } - : '%data' qcname tbinds '=' '{' cons1 '}' - { TyClD (TyData DataType [] $2 $3 (DataCons $6) Nothing [] noSrcLoc) } - | '%newtype' qcname tbinds trep - { TyClD (TyData NewType [] $2 $3 ($4 $2 $3) Nothing [] noSrcLoc) } - -trep :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) } - : {- empty -} { (\ x ts -> Unknown) } - | '=' ty { (\ x ts -> DataCons [ConDecl x x ts [] (VanillaCon [unbangedType $2]) noSrcLoc]) } + : '%data' q_tc_name tbinds '=' '{' cons1 '}' + { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) } + | '%newtype' q_tc_name tbinds trep + { TyClD (mkTyData NewType ([], $2, $3) ($4 $2) Nothing noSrcLoc) } + +-- 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 :: { (RdrName -> DataConDetails (ConDecl RdrName)) } + : {- empty -} { (\ tc_name -> Unknown) } + | '=' ty { (\ tc_name -> let { dc_name = setRdrNameSpace tc_name dataName ; + con_info = PrefixCon [unbangedType $2] } + in DataCons [ConDecl dc_name [] [] con_info noSrcLoc]) } tbind :: { HsTyVarBndr RdrName } : name { IfaceTyVar $1 liftedTypeKind } @@ -94,15 +102,22 @@ vdefgs :: { [[RdrNameHsDecl]] } | vdefg ';' vdefgs { ($1:$3) } vdefg :: { [RdrNameHsDecl] } - : '%rec' '{' vdefs1 '}' { $3 } - | vdef { [$1] } + : '%rec' '{' vdefs1 '}' { map CoreD $3 } + | vdef { [CoreD $1] } + +let_bind :: { UfBinding RdrName } + : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3) } + | vdef { let (b,r) = convBind $1 + in UfNonRec b r } -vdefs1 :: { [RdrNameHsDecl] } +vdefs1 :: { [RdrNameCoreDecl] } : vdef { [$1] } | vdef ';' vdefs1 { $1:$3 } -vdef :: { RdrNameHsDecl } - : qname '::' ty '=' exp { TyClD (CoreDecl $1 $3 $5 noSrcLoc) } +vdef :: { RdrNameCoreDecl } + : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc } + -- NB: qname includes data constructors, because + -- we allow data-constructor wrappers at top level vbind :: { (RdrName, RdrNameHsType) } @@ -139,8 +154,8 @@ cons1 :: { [ConDecl RdrName] } | con ';' cons1 { $1:$3 } con :: { ConDecl RdrName } - : qcname attbinds atys - { ConDecl $1 $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc} + : q_d_patt attbinds atys + { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc} atys :: { [ RdrNameHsType] } : {- empty -} { [] } @@ -148,7 +163,7 @@ atys :: { [ RdrNameHsType] } aty :: { RdrNameHsType } : name { HsTyVar $1 } - | qcname { HsTyVar $1 } + | q_tc_name { HsTyVar $1 } | '(' ty ')' { $2 } @@ -163,7 +178,6 @@ ty :: { RdrNameHsType } aexp :: { UfExpr RdrName } : qname { UfVar $1 } - | qcname { UfVar $1 } | lit { UfLit $1 } | '(' exp ')' { $2 } @@ -175,7 +189,7 @@ fexp :: { UfExpr RdrName } exp :: { UfExpr RdrName } : fexp { $1 } | '\\' binds1 '->' exp { foldr UfLam $4 $2 } - | '%let' vdefg '%in' exp { UfLet (toUfBinder $2) $4 } + | '%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? @@ -192,21 +206,21 @@ alts1 :: { [UfAlt RdrName] } | alt ';' alts1 { $1:$3 } alt :: { UfAlt RdrName } - : qcname attbinds vbinds '->' exp - { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) } + : q_d_patt attbinds vbinds '->' exp + { (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) } | lit '->' exp { (UfLitAlt $1, [], $3) } | '%_' '->' exp { (UfDefault, [], $3) } lit :: { Literal } - : '(' INTEGER '::' aty ')' { MachInt $2 } - | '(' RATIONAL '::' aty ')' { MachDouble $2 } + : '(' INTEGER '::' aty ')' { convIntLit $2 $4 } + | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 } | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) } - | '(' STRING '::' aty ')' { MachStr (_PK_ $2) } + | '(' STRING '::' aty ')' { MachStr (mkFastString $2) } name :: { RdrName } - : NAME { mkUnqual varName (_PK_ $1) } + : NAME { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) } cname :: { String } : CNAME { $1 } @@ -215,29 +229,58 @@ mname :: { String } : CNAME { $1 } modid :: { ModuleName } - : CNAME { mkSysModuleNameFS (_PK_ $1) } + : CNAME { mkSysModuleNameFS (mkFastString $1) } + +qname :: { RdrName } -- Includes data constructors + : name { $1 } + | mname '.' NAME { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) } + | q_d_occ { $1 } -qname :: { RdrName } - : name { $1 } - | mname '.' NAME - { mkIfaceOrig varName (_PK_ $1,_PK_ $3) } -qcname :: { RdrName } +-- Type constructor +q_tc_name :: { RdrName } : mname '.' cname - { mkIfaceOrig dataName (_PK_ $1,_PK_ $3) } + { mkIfaceOrig tcName (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 +q_d_patt :: { RdrName } + : mname '.' cname + { mkIfaceOrig dataName (mkFastString $1) (mkFastString $3) } + +-- Data constructor occurrence in an expression; +-- use the varName because that's the worker Id +q_d_occ :: { RdrName } + : mname '.' cname + { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) } -{ -toUfBinder :: [RdrNameHsDecl] -> UfBinding RdrName -toUfBinder xs = - case xs of - [x] -> uncurry UfNonRec (conv x) - _ -> UfRec (map conv xs) - where - conv (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs) +{ +convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName) +convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs) + +convIntLit :: Integer -> RdrNameHsType -> Literal +convIntLit i (HsTyVar n) + | n == intPrimRdrName = MachInt i + | n == wordPrimRdrName = MachWord i +convIntLit i aty + = pprPanic "Unknown integer literal type" (ppr aty $$ ppr intPrimRdrName) + +convRatLit :: Rational -> RdrNameHsType -> Literal +convRatLit r (HsTyVar n) + | n == floatPrimRdrName = MachFloat r + | n == doublePrimRdrName = MachDouble r +convRatLit i aty + = pprPanic "Unknown rational literal type" (ppr aty $$ ppr intPrimRdrName) + + +wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName :: RdrName +wordPrimRdrName = nameRdrName wordPrimTyConName +intPrimRdrName = nameRdrName intPrimTyConName +floatPrimRdrName = nameRdrName floatPrimTyConName +doublePrimRdrName = nameRdrName doublePrimTyConName happyError :: P a happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l - } +