X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParserCore.y;h=8bf94539fa42f00aacd004d7b7750fc2013fa68d;hp=a9669b23ec4619608b42aa0d47267c6a93584aa0;hb=d2f11ea842a25bebd51d6c0c730a756c1d987e25;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index a9669b2..8bf9453 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -1,4 +1,12 @@ { +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module ParserCore ( parseCore ) where import IfaceSyn @@ -7,10 +15,13 @@ import RdrHsSyn import HsSyn import RdrName import OccName -import Kind( Kind(..) ) -import Name( nameOccName, nameModule ) +import Type ( Kind, + liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, mkTyConApp + ) +import Coercion( mkArrowKind ) +import Name( Name, nameOccName, nameModule, mkExternalName ) import Module -import PackageConfig ( mainPackageId ) import ParserCoreUtils import LexCore import Literal @@ -20,13 +31,15 @@ import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, import TyCon ( TyCon, tyConName ) import FastString import Outputable -import Char +import Data.Char +import Unique #include "../HsVersions.h" } %name parseCore +%expect 0 %tokentype { Token } %token @@ -39,9 +52,10 @@ import Char '%in' { TKin } '%case' { TKcase } '%of' { TKof } - '%coerce' { TKcoerce } + '%cast' { TKcast } '%note' { TKnote } '%external' { TKexternal } + '%local' { TKlocal } '%_' { TKwild } '(' { TKoparen } ')' { TKcparen } @@ -49,7 +63,9 @@ import Char '}' { TKcbrace } '#' { TKhash} '=' { TKeq } + ':' { TKcolon } '::' { TKcoloncolon } + ':=:' { TKcoloneqcolon } '*' { TKstar } '->' { TKrarrow } '\\' { TKlambda} @@ -70,25 +86,58 @@ import Char %% module :: { HsExtCore RdrName } - : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 } + -- : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 } + : '%module' modid tdefs vdefgs { HsExtCore $2 [] [] } + + +------------------------------------------------------------- +-- Names: the trickiest bit in here +-- A name of the form A.B.C could be: +-- module A.B.C +-- dcon C in module A.B +-- tcon C in module A.B modid :: { Module } - : CNAME { mkModule mainPackageId -- ToDo: wrong - (mkModuleNameFS (mkFastString $1)) } + : NAME ':' mparts { undefined } + +q_dc_name :: { Name } + : NAME ':' mparts { undefined } + +q_tc_name :: { Name } + : NAME ':' mparts { undefined } + +q_var_occ :: { Name } + : NAME ':' vparts { undefined } + +mparts :: { [String] } + : CNAME { [$1] } + | CNAME '.' mparts { $1:$3 } + +vparts :: { [String] } + : var_occ { [$1] } + | CNAME '.' vparts { $1:$3 } ------------------------------------------------------------- -- Type and newtype declarations are in HsSyn syntax tdefs :: { [TyClDecl RdrName] } : {- empty -} {[]} - | tdef ';' tdefs {$1:$3} + | tdef tdefs {$1:$2} tdef :: { TyClDecl RdrName } - : '%data' q_tc_name tv_bndrs '=' '{' cons '}' - { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) Nothing $6 Nothing } - | '%newtype' q_tc_name tv_bndrs trep + : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';' + { TyData { tcdND = DataType, tcdCtxt = noLoc [] + , tcdLName = noLoc (ifaceExtRdrName $2) + , tcdTyVars = map toHsTvBndr $3 + , tcdTyPats = Nothing, tcdKindSig = Nothing + , tcdCons = $6, tcdDerivs = 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 } + TyData { tcdND = NewType, tcdCtxt = noLoc [] + , tcdLName = noLoc tc_rdr + , tcdTyVars = map toHsTvBndr $3 + , tcdTyPats = Nothing, tcdKindSig = Nothing + , tcdCons = $4 (rdrNameOcc tc_rdr), tcdDerivs = 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 @@ -96,24 +145,18 @@ 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]) } + in [noLoc $ mkSimpleConDecl (noLoc dc_name) [] + (noLoc []) con_info]) } cons :: { [LConDecl RdrName] } : {- empty -} { [] } -- 20060420 Empty data types allowed. jds + | con { [$1] } | con ';' cons { $1:$3 } 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) } + { noLoc $ mkSimpleConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3) } +-- ToDo: parse record-style declarations attv_bndrs :: { [LHsTyVarBndr RdrName] } : {- empty -} { [] } @@ -132,12 +175,13 @@ atys :: { [IfaceType] } | aty atys { $1:$2 } aty :: { IfaceType } - : tv_occ { IfaceTyVar $1 } + : fs_var_occ { IfaceTyVar $1 } | q_tc_name { IfaceTyConApp (IfaceTc $1) [] } | '(' ty ')' { $2 } bty :: { IfaceType } - : tv_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 } + : fs_var_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 } + | q_var_occ atys { undefined } | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 } | '(' ty ')' { $2 } @@ -154,25 +198,23 @@ vdefgs :: { [IfaceBinding] } | let_bind ';' vdefgs { $1 : $3 } let_bind :: { IfaceBinding } - : '%rec' '{' vdefs1 '}' { IfaceRec $3 } + : '%rec' '{' vdefs1 '}' { IfaceRec $3 } -- Can be empty. Do we care? | vdef { let (b,r) = $1 in IfaceNonRec b r } -vdefs1 :: { [(IfaceIdBndr, IfaceExpr)] } - : vdef { [$1] } +vdefs1 :: { [(IfaceLetBndr, IfaceExpr)] } + : vdef { [$1] } | vdef ';' vdefs1 { $1:$3 } -vdef :: { (IfaceIdBndr, IfaceExpr) } - : qd_occ '::' ty '=' exp { (($1, $3), $5) } +vdef :: { (IfaceLetBndr, IfaceExpr) } + : fs_var_occ '::' ty '=' exp { (IfLetBndr $1 $3 NoInfo, $5) } + | '%local' vdef { $2 } + -- 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 - -qd_occ :: { FastString } - : var_occ { $1 } - | d_occ { $1 } + -- has OccNames in binding positions. Ah, but it has Names now! --------------------------------------- -- Binders @@ -185,36 +227,34 @@ bndrs :: { [IfaceBndr] } | bndr bndrs { $1:$2 } id_bndr :: { IfaceIdBndr } - : '(' var_occ '::' ty ')' { ($2,$4) } - -id_bndrs :: { [IfaceIdBndr] } - : {-empty -} { [] } - | id_bndr id_bndrs { $1:$2 } + : '(' fs_var_occ '::' ty ')' { ($2,$4) } tv_bndr :: { IfaceTvBndr } - : tv_occ { ($1, LiftedTypeKind) } - | '(' tv_occ '::' akind ')' { ($2, $4) } + : fs_var_occ { ($1, ifaceLiftedTypeKind) } + | '(' fs_var_occ '::' akind ')' { ($2, $4) } tv_bndrs :: { [IfaceTvBndr] } : {- empty -} { [] } | 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 } + | ty ':=:' ty { ifaceEq $1 $3 } ----------------------------------------- -- Expressions aexp :: { IfaceExpr } - : var_occ { IfaceLcl $1 } - | modid '.' qd_occ { IfaceExt (ExtPkg $1 (mkVarOccFS $3)) } + : fs_var_occ { IfaceLcl $1 } + | q_var_occ { IfaceExt $1 } + | q_dc_name { IfaceExt $1 } | lit { IfaceLit $1 } | '(' exp ')' { $2 } @@ -230,14 +270,15 @@ exp :: { IfaceExpr } -- 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" -> IfaceNote (IfaceSCC "scc") $3 - "InlineMe" -> IfaceNote IfaceInlineMe $3 - } + | '%cast' aexp aty { IfaceCast $2 $3 } +-- No InlineMe any more +-- | '%note' STRING exp +-- { case $2 of +-- --"SCC" -> IfaceNote (IfaceSCC "scc") $3 +-- "InlineMe" -> IfaceNote IfaceInlineMe $3 +-- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall - (CCallSpec (StaticTarget (mkFastString $2)) + (CCallSpec (StaticTarget (mkFastString $2) Nothing) CCallConv (PlaySafe False))) $3 } @@ -246,11 +287,13 @@ alts1 :: { [IfaceAlt] } | alt ';' alts1 { $1:$3 } alt :: { IfaceAlt } - : modid '.' d_pat_occ bndrs '->' exp - { (IfaceDataAlt $3, map ifaceBndrName $4, $6) } + : q_dc_name bndrs '->' exp + { (IfaceDataAlt $1, map ifaceBndrName $2, $4) } -- The external syntax currently includes the types of the -- the args, but they aren't needed internally -- Nor is the module qualifier + | q_dc_name '->' exp + { (IfaceDataAlt $1, [], $3) } | lit '->' exp { (IfaceLitAlt $1, [], $3) } | '%_' '->' exp @@ -262,29 +305,22 @@ lit :: { Literal } | '(' CHAR '::' aty ')' { MachChar $2 } | '(' STRING '::' aty ')' { MachStr (mkFastString $2) } -tv_occ :: { FastString } - : NAME { mkFastString $1 } - -var_occ :: { FastString } - : NAME { mkFastString $1 } +fs_var_occ :: { FastString } + : NAME { mkFastString $1 } +var_occ :: { String } + : NAME { $1 } --- Type constructor -q_tc_name :: { IfaceExtName } - : modid '.' CNAME { 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 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 :: { FastString } - : CNAME { mkFastString $1 } - { +ifaceKind kc = IfaceTyConApp kc [] + ifaceBndrName (IfaceIdBndr (n,_)) = n ifaceBndrName (IfaceTvBndr (n,_)) = n @@ -305,10 +341,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, @@ -316,17 +349,42 @@ eqTc (IfaceTc (ExtPkg mod occ)) tycon -- are very limited (see the productions for 'ty', so the translation -- isn't hard toHsType :: IfaceType -> LHsType RdrName -toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOcc v)) +toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOccFS 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) +-- 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 + +ifaceEq ifT1 ifT2 = IfacePredTy (IfaceEqPred ifT1 ifT2) + toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) k +toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS 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))