From: Aaron Tomb Date: Mon, 13 Nov 2006 23:01:32 +0000 (+0000) Subject: Fix external core syntax (though not full compilation) X-Git-Tag: 2007-05-06~218 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=de777ba42eb12b6a20e548a959b23b60179d9b57 Fix external core syntax (though not full compilation) This patch updates the External Core creator, pretty-printer, and parser to agree on a concrete syntax for External Core, including the constructs required by the change to System FC. Code to create valid ASTs from External Core files will come later, as will bits for renaming, typechecking, and desugaring. --- diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs index 89b2712..2fdcf2d 100644 --- a/compiler/coreSyn/ExternalCore.lhs +++ b/compiler/coreSyn/ExternalCore.lhs @@ -62,6 +62,7 @@ data Kind | Kunboxed | Kopen | Karrow Kind Kind + | Keq Ty Ty data Lit = Lint Integer Ty diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 150ae16..de907cf 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -20,6 +20,7 @@ import Type import PprExternalCore -- Instances import DataCon import CoreSyn +import Coercion import Var import IdInfo import Literal @@ -179,7 +180,8 @@ make_ty (NoteTy _ t) = make_ty t make_kind :: Kind -> C.Kind -make_kind (PredTy p) | isEqPred p = panic "coercion kinds in external core not implemented!" +make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2) + where (t1, t2) = getEqPredTys p make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2) make_kind k | isLiftedTypeKind k = C.Klifted diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs index 502c268..9f4c011 100644 --- a/compiler/coreSyn/PprExternalCore.lhs +++ b/compiler/coreSyn/PprExternalCore.lhs @@ -76,6 +76,7 @@ pakind (Kopen) = char '?' pakind k = parens (pkind k) pkind (Karrow k1 k2) = parens (pakind k1 <> text "->" <> pkind k2) +pkind (Keq t1 t2) = parens (pty t1 <> text ":=:" <> pty t2) pkind k = pakind k paty (Tvar n) = pname n @@ -132,7 +133,7 @@ pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e) pexp (Case e vb ty alts) = sep [text "%case" <+> parens (paty ty) <+> paexp e, text "%of" <+> pvbind vb] $$ (indent (braces (vcat (punctuate (char ';') (map palt alts))))) -pexp (Cast e co) = (text "%cast" <+> pexp e) $$ paty co +pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paty co pexp (Note s e) = (text "%note" <+> pstring s) $$ pexp e pexp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ paty t pexp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ paty t diff --git a/compiler/parser/LexCore.hs b/compiler/parser/LexCore.hs index 936786d..9109c04 100644 --- a/compiler/parser/LexCore.hs +++ b/compiler/parser/LexCore.hs @@ -6,7 +6,7 @@ import Char import Numeric isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'') - || (c == ':') || (c == '$') + || (c == '$') || (c == '-') || (c == '.') isKeywordChar c = isAlpha c || (c == '_') lexer :: (Token -> P a) -> P a @@ -29,6 +29,7 @@ lexer cont (')':cs) = cont TKcparen cs lexer cont ('{':cs) = cont TKobrace cs lexer cont ('}':cs) = cont TKcbrace cs lexer cont ('=':cs) = cont TKeq cs +lexer cont (':':'=':':':cs) = cont TKcoloneqcolon cs lexer cont (':':':':cs) = cont TKcoloncolon cs lexer cont ('*':cs) = cont TKstar cs lexer cont ('.':cs) = cont TKdot cs @@ -37,7 +38,9 @@ lexer cont ('@':cs) = cont TKat cs lexer cont ('?':cs) = cont TKquestion cs lexer cont (';':cs) = cont TKsemicolon cs -- 20060420 GHC spits out constructors with colon in them nowadays. jds -lexer cont (':':cs) = lexName cont TKcname (':':cs) +-- 20061103 but it's easier to parse if we split on the colon, and treat them +-- as several tokens +lexer cont (':':cs) = cont TKcolon cs -- 20060420 Likewise does it create identifiers starting with dollar. jds lexer cont ('$':cs) = lexName cont TKname ('$':cs) lexer cont (c:cs) = failP "invalid character" [c] @@ -94,6 +97,7 @@ lexKeyword cont cs = ("cast",rest) -> cont TKcast rest ("note",rest) -> cont TKnote rest ("external",rest) -> cont TKexternal rest + ("local",rest) -> cont TKlocal rest ("_",rest) -> cont TKwild rest _ -> failP "invalid keyword" ('%':cs) diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index b37add3..225c164 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -11,9 +11,9 @@ import Type ( Kind, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, mkArrowKind, mkTyConApp ) -import Name( Name, nameOccName, nameModule ) +import Name( Name, nameOccName, nameModule, mkExternalName ) import Module -import PackageConfig ( mainPackageId ) +import PackageConfig ( mainPackageId, stringToPackageId ) import ParserCoreUtils import LexCore import Literal @@ -24,6 +24,7 @@ import TyCon ( TyCon, tyConName ) import FastString import Outputable import Char +import Unique #include "../HsVersions.h" @@ -45,6 +46,7 @@ import Char '%cast' { TKcast } '%note' { TKnote } '%external' { TKexternal } + '%local' { TKlocal } '%_' { TKwild } '(' { TKoparen } ')' { TKcparen } @@ -52,7 +54,9 @@ import Char '}' { TKcbrace } '#' { TKhash} '=' { TKeq } + ':' { TKcolon } '::' { TKcoloncolon } + ':=:' { TKcoloneqcolon } '*' { TKstar } '->' { TKrarrow } '\\' { TKlambda} @@ -73,27 +77,52 @@ 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 '}' + : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';' { mkTyData DataType ( noLoc [] , noLoc (ifaceExtRdrName $2) , map toHsTvBndr $3 , Nothing ) Nothing $6 Nothing } - | '%newtype' q_tc_name tv_bndrs trep + | '%newtype' q_tc_name tv_bndrs trep ';' { let tc_rdr = ifaceExtRdrName $2 in mkTyData NewType ( noLoc [] , noLoc tc_rdr @@ -112,6 +141,7 @@ trep :: { OccName -> [LConDecl RdrName] } cons :: { [LConDecl RdrName] } : {- empty -} { [] } -- 20060420 Empty data types allowed. jds + | con { [$1] } | con ';' cons { $1:$3 } con :: { LConDecl RdrName } @@ -143,12 +173,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 } @@ -165,25 +196,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] } + : vdef { [$1] } | vdef ';' vdefs1 { $1:$3 } vdef :: { (IfaceIdBndr, IfaceExpr) } - : qd_occ '::' ty '=' exp { (($1, $3), $5) } + : fs_var_occ '::' ty '=' exp { (($1, $3), $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 @@ -196,15 +225,11 @@ 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, ifaceLiftedTypeKind) } - | '(' tv_occ '::' akind ')' { ($2, $4) } + : fs_var_occ { ($1, ifaceLiftedTypeKind) } + | '(' fs_var_occ '::' akind ')' { ($2, $4) } tv_bndrs :: { [IfaceTvBndr] } : {- empty -} { [] } @@ -219,13 +244,15 @@ akind :: { IfaceKind } kind :: { IfaceKind } : akind { $1 } | akind '->' kind { ifaceArrow $1 $3 } + | ty ':=:' ty { ifaceEq $1 $3 } ----------------------------------------- -- Expressions aexp :: { IfaceExpr } - : var_occ { IfaceLcl $1 } - | modid '.' qd_occ { IfaceExt undefined {-ToDo!!! (ExtPkg $1 (mkVarOccFS $3))-} } + : fs_var_occ { IfaceLcl $1 } + | q_var_occ { IfaceExt $1 } + | q_dc_name { IfaceExt $1 } | lit { IfaceLit $1 } | '(' exp ')' { $2 } @@ -241,7 +268,7 @@ exp :: { IfaceExpr } -- gaw 2004 | '%case' '(' ty ')' aexp '%of' id_bndr '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 } - | '%cast' exp aty { IfaceCast $2 $3 } + | '%cast' aexp aty { IfaceCast $2 $3 } | '%note' STRING exp { case $2 of --"SCC" -> IfaceNote (IfaceSCC "scc") $3 @@ -257,11 +284,13 @@ alts1 :: { [IfaceAlt] } | alt ';' alts1 { $1:$3 } alt :: { IfaceAlt } - : modid '.' d_pat_occ bndrs '->' exp - { (IfaceDataAlt undefined {-ToDo!!! $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 @@ -273,27 +302,18 @@ lit :: { Literal } | '(' CHAR '::' aty ')' { MachChar $2 } | '(' STRING '::' aty ')' { MachStr (mkFastString $2) } -tv_occ :: { FastString } - : NAME { mkFastString $1 } +fs_var_occ :: { FastString } + : NAME { mkFastString $1 } -var_occ :: { FastString } - : NAME { mkFastString $1 } +var_occ :: { String } + : NAME { $1 } --- Type constructor -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 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 [] @@ -355,6 +375,8 @@ 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)) (toKind k) diff --git a/compiler/parser/ParserCoreUtils.hs b/compiler/parser/ParserCoreUtils.hs index 4aa3341..124294b 100644 --- a/compiler/parser/ParserCoreUtils.hs +++ b/compiler/parser/ParserCoreUtils.hs @@ -30,6 +30,7 @@ getCoreModuleName fpath = (\ _ -> return "Main") where findMod [] = "Main" + -- TODO: this should just return the module name, without the package name findMod ("%module":m:_) = m findMod (_:xs) = findMod xs @@ -47,6 +48,7 @@ data Token = | TKcast | TKnote | TKexternal + | TKlocal | TKwild | TKoparen | TKcparen @@ -54,7 +56,9 @@ data Token = | TKcbrace | TKhash | TKeq + | TKcolon | TKcoloncolon + | TKcoloneqcolon | TKstar | TKrarrow | TKlambda