From 2ad4df602e5bb2cff0315b945fa3201749878c30 Mon Sep 17 00:00:00 2001 From: Tim Chevalier Date: Wed, 16 Apr 2008 00:03:47 +0000 Subject: [PATCH] Improve External Core syntax Got rid of the silly '^' characters before qualified names (plus: reverts to the original syntax; minus: makes the parser a little hairier.) Also, added warning in the typechecker for coercion kind mismatches rather than considering that a type error. (see the added comment in Check.hs for details.) --- compiler/coreSyn/PprExternalCore.lhs | 5 +-- utils/ext-core/Check.hs | 22 +++++++++- utils/ext-core/Core.hs | 11 ++--- utils/ext-core/ParsecParser.hs | 75 +++++++++++++++++++--------------- utils/ext-core/Printer.hs | 29 ++++++------- 5 files changed, 85 insertions(+), 57 deletions(-) diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs index e46a871..ffa4675 100644 --- a/compiler/coreSyn/PprExternalCore.lhs +++ b/compiler/coreSyn/PprExternalCore.lhs @@ -82,10 +82,7 @@ pname id = text (zEncodeString id) pqname :: Qual Id -> Doc pqname ("",id) = pname id --- We print out a special character before a qualified name so as to --- disambiguate unqualified names like "m" from qualified names like --- "m:Foo.Bar.y". This makes the ext-core parser easier. -pqname (m,id) = char '^' <> text m <> char '.' <> pname id +pqname (m,id) = text m <> char '.' <> pname id ptbind, pattbind :: Tbind -> Doc ptbind (t,Klifted) = pname t diff --git a/utils/ext-core/Check.hs b/utils/ext-core/Check.hs index 29fb71f..95c7281 100644 --- a/utils/ext-core/Check.hs +++ b/utils/ext-core/Check.hs @@ -8,6 +8,8 @@ module Check( import Maybe import Control.Monad.Reader +-- just for printing warnings +import System.IO.Unsafe import Core import Printer() @@ -301,7 +303,7 @@ checkType mn menv tdefs tvenv t = case runReaderT (do checkExp :: (Tcenv,Tsenv,Tvenv,Cenv,Venv,Venv) -> Exp -> CheckResult Ty checkExp (tcenv,tsenv,tvenv,cenv,e_venv,l_venv) = ch where - ch e0 = + ch e0 = case e0 of Var qv -> qlookupM venv_ e_venv l_venv qv @@ -485,7 +487,21 @@ checkTy es@(tcenv,tvenv) t = ch t ("Arity mismatch in coercion app: " ++ show t) let (tvs, tks) = unzip tbs argKs <- mapM (checkTy es) tys - require (all (uncurry eqKind) (zip tks argKs)) + let kPairs = zip argKs tks + let kindsOk = all (uncurry eqKind) kPairs + if not kindsOk && + all (uncurry subKindOf) kPairs + -- GHC occasionally generates code like: + -- :Co:TTypeable2 (->) + -- where in this case, :Co:TTypeable2 expects an + -- argument of kind (*->(*->*)) and (->) has kind + -- (?->(?->*)). In general, I don't think it's + -- sound to apply an arbitrary coercion to an + -- argument that's a subkind of what it expects. + then warn $ "Applying coercion " ++ show tc ++ + " to arguments of kind " ++ show argKs + ++ " when it expects: " ++ show tks + else require kindsOk ("Kind mismatch in coercion app: " ++ show tks ++ " and " ++ show argKs ++ " t = " ++ show t) return $ Keq (substl tvs tys from) (substl tvs tys to) @@ -696,3 +712,5 @@ reportError :: Show a => a -> String -> b reportError e s = error $ ("Core type error: checkExpr failed with " ++ s ++ " and " ++ show e) +warn :: String -> CheckResult () +warn s = (unsafePerformIO $ putStrLn ("WARNING: " ++ s)) `seq` return () \ No newline at end of file diff --git a/utils/ext-core/Core.hs b/utils/ext-core/Core.hs index ce2a11d..5f8ed82 100644 --- a/utils/ext-core/Core.hs +++ b/utils/ext-core/Core.hs @@ -108,7 +108,8 @@ data CoreLit = Lint Integer -- with Nothing. type Mname = Maybe AnMname -type AnMname = (Pname, [Id], Id) +newtype AnMname = M (Pname, [Id], Id) + deriving (Eq, Ord) type Pname = Id type Var = Id type Tvar = Id @@ -179,8 +180,8 @@ isPrimVar _ = False primMname = mkPrimMname "Prim" errMname = mkBaseMname "Err" mkBaseMname,mkPrimMname :: Id -> AnMname -mkBaseMname mn = (basePkg, ghcPrefix, mn) -mkPrimMname mn = (primPkg, ghcPrefix, mn) +mkBaseMname mn = M (basePkg, ghcPrefix, mn) +mkPrimMname mn = M (primPkg, ghcPrefix, mn) basePkg = "base" mainPkg = "main" primPkg = zEncodeString "ghc-prim" @@ -189,8 +190,8 @@ mainPrefix = [] baseMname = mkBaseMname "Base" boolMname = mkPrimMname "Bool" mainVar = qual mainMname "main" -mainMname = (mainPkg, mainPrefix, "Main") -wrapperMainMname = Just (mainPkg, mainPrefix, "ZCMain") +mainMname = M (mainPkg, mainPrefix, "Main") +wrapperMainMname = Just $ M (mainPkg, mainPrefix, "ZCMain") tcArrow :: Qual Tcon tcArrow = (Just primMname, "ZLzmzgZR") diff --git a/utils/ext-core/ParsecParser.hs b/utils/ext-core/ParsecParser.hs index b539962..f080093 100644 --- a/utils/ext-core/ParsecParser.hs +++ b/utils/ext-core/ParsecParser.hs @@ -1,6 +1,6 @@ -{-# OPTIONS -Wall -Werror -fno-warn-missing-signatures #-} +{-# OPTIONS -Wall -fno-warn-missing-signatures #-} -module ParsecParser where +module ParsecParser (parseCore) where import Core import ParseGlue @@ -8,9 +8,9 @@ import Check import PrimCoercions import Text.ParserCombinators.Parsec ---import Text.ParserCombinators.Parsec.Expr import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language +import Data.Char import Data.Ratio parseCore :: FilePath -> IO (Either ParseError Module) @@ -32,7 +32,7 @@ coreModuleName = do pkgName <- corePackageName char ':' (modHierarchy,baseName) <- coreHierModuleNames - return (pkgName, modHierarchy, baseName) + return $ M (pkgName, modHierarchy, baseName) corePackageName :: Parser Pname -- Package names can be lowercase or uppercase! @@ -92,11 +92,24 @@ coreQualifiedCon = coreQualifiedGen upperName coreQualifiedName = coreQualifiedGen identifier -coreQualifiedGen p = do - maybeMname <- coreMaybeMname - theId <- p - return (maybeMname, theId) - +coreQualifiedGen :: Parser String -> Parser (Mname, Id) +coreQualifiedGen p = (try (do + packageIdOrVarName <- corePackageName + maybeRest <- optionMaybe (char ':' >> coreHierModuleNames) + case maybeRest of + -- unqualified id, so backtrack + Nothing -> pzero + -- qualified name, so look for the id part + Just (modHierarchy, baseName) -> do + char '.' + theId <- p + return + (Just $ M (packageIdOrVarName, modHierarchy, baseName), + theId))) <|> + -- unqualified name + (p >>= (\ res -> return (Nothing, res))) + +{- coreMaybeMname = optionMaybe coreMname coreRequiredQualifiedName = do @@ -105,12 +118,11 @@ coreRequiredQualifiedName = do return (Just mname, theId) coreMname = do --- Notice the '^' goes here: --- it's part of a variable *occurrence*, not a module name. char '^' nm <- try coreModuleName symbol "." return nm +-} coreAxiom :: Parser Axiom coreAxiom = parens (do @@ -236,20 +248,11 @@ data CoercionTy = TransC | SymC | UnsafeC | LeftC | RightC symCo, transCo, unsafeCo :: Parser CoercionTy -- Would be better not to wire these in quite this way. Sigh -symCo = string "^ghczmprim:GHCziPrim.sym" >> return SymC -transCo = string "^ghczmprim:GHCziPrim.trans" >> return TransC -unsafeCo = string "^ghczmprim:GHCziPrim.CoUnsafe" >> return UnsafeC -leftCo = string "^ghczmprim:GHCziPrim.left" >> return LeftC -rightCo = string "^ghczmprim:GHCziPrim.right" >> return RightC - -coreFunTy :: Parser Ty -coreFunTy = do - argTy <- coreBty - whiteSpace - symbol "->" - whiteSpace - resTy <- coreType - return $ tArrow argTy resTy +symCo = string "ghczmprim:GHCziPrim.sym" >> return SymC +transCo = string "ghczmprim:GHCziPrim.trans" >> return TransC +unsafeCo = string "ghczmprim:GHCziPrim.CoUnsafe" >> return UnsafeC +leftCo = string "ghczmprim:GHCziPrim.left" >> return LeftC +rightCo = string "ghczmprim:GHCziPrim.right" >> return RightC coreForallTy :: Parser Ty coreForallTy = do @@ -316,7 +319,9 @@ coreRecVdef = do coreNonrecVdef = coreVdef >>= (return . Nonrec) coreVdef = do - (vdefLhs, vdefTy) <- topVbind + (vdefLhs, vdefTy) <- try topVbind <|> (do + (v, ty) <- lambdaBind + return (unqual v, ty)) whiteSpace symbol "=" whiteSpace @@ -328,8 +333,7 @@ coreAtomicExp = do -- For stupid reasons, the whiteSpace is necessary. -- Without it, (pt coreAppExp "w ^a:B.C ") doesn't work. whiteSpace - res <- choice [ try coreVar, - coreDcon, + res <- choice [try coreDconOrVar, try coreLit, parens coreFullExp ] whiteSpace @@ -356,9 +360,13 @@ coreAppExp = do return $ foldl (\ op -> either (App op) (Appt op)) oper args -coreVar = ((try coreQualifiedName) <|> (identifier >>= (return . unqual))) - >>= (return . Var) -coreDcon = coreQualifiedCon >>= (return . Dcon) +coreDconOrVar = do + theThing <- coreQualifiedGen (try upperName <|> identifier) + return $ case theThing of + -- note that data constructors must be qualified + (Just _, idItself) | isUpper (head idItself) + -> Dcon theThing + _ -> Var theThing coreLit :: Parser Exp coreLit = parens (coreLiteral >>= (return . Lit)) @@ -434,7 +442,9 @@ coreVbind = parens (lambdaBind >>= (return . Vb)) coreAtTbind = (symbol "@") >> coreTbind +topVbind :: Parser (Qual Var, Ty) topVbind = aCoreVbind coreQualifiedName +lambdaBind :: Parser (Var, Ty) lambdaBind = aCoreVbind identifier aCoreVbind idP = do @@ -506,7 +516,6 @@ extCore = P.makeTokenParser extCoreDef parens = P.parens extCore braces = P.braces extCore -semiSep1 = P.semiSep1 extCore -- newlines are allowed anywhere whiteSpace = P.whiteSpace extCore <|> (newline >> return ()) symbol = P.symbol extCore @@ -537,6 +546,7 @@ extCoreDef = LanguageDef { , caseSensitive = True } +{- -- Stuff to help with testing in ghci. pTest (Left a) = error (show a) pTest (Right t) = print t @@ -561,3 +571,4 @@ andThenSym a b = do p <- a symbol b return p +-} \ No newline at end of file diff --git a/utils/ext-core/Printer.hs b/utils/ext-core/Printer.hs index 0b6be42..0cd8b09 100644 --- a/utils/ext-core/Printer.hs +++ b/utils/ext-core/Printer.hs @@ -48,6 +48,9 @@ instance Show KindOrCoercion where shows (text " hsep (map ptbind tbs) <+> parens (pkind (Keq t1 t2)) <> text ">") +instance Show AnMname where + showsPrec _ mn = shows (panmname mn) + indent = nest 2 -- seems like this is asking for a type class... @@ -84,11 +87,9 @@ pqname (m,v) = pmname m <> pname v -- be sure to print the '.' here so we don't print out -- ".foo" for unqualified foo... pmname Nothing = empty --- Notice that we print the "^" here; this is so that --- "%module foo" doesn't get printed as "%module ^foo" -pmname (Just m) = char '^' <> panmname m <> char '.' +pmname (Just m) = panmname m <> char '.' -panmname (pkgName, parents, name) = +panmname (M (pkgName, parents, name)) = let parentStrs = map pname parents in pname pkgName <> char ':' <> -- This is to be sure to not print out: @@ -124,16 +125,6 @@ peqkind (t1, t2) = parens (parens (pty t1) <+> text ":=:" <+> parens (pty t2)) paty (Tvar n) = pname n paty (Tcon c) = pqname c -paty (TransCoercion t1 t2) = - parens (sep ([pqname transCoercion, pbty t1, pbty t2])) -paty (SymCoercion t) = - parens (sep [pqname symCoercion, paty t]) -paty (UnsafeCoercion t1 t2) = - parens (sep [pqname unsafeCoercion, pbty t1, pbty t2]) -paty (LeftCoercion t) = - parens (pqname leftCoercion <+> paty t) -paty (RightCoercion t) = - parens (pqname rightCoercion <+> paty t) paty t = parens (pty t) pbty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = parens(fsep [pbty t1, text "->",pty t2]) @@ -142,6 +133,16 @@ pbty t = paty t pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2] pty (Tforall tb t) = text "%forall" <+> pforall [tb] t +pty (TransCoercion t1 t2) = + (sep ([pqname transCoercion, paty t1, paty t2])) +pty (SymCoercion t) = + (sep [pqname symCoercion, paty t]) +pty (UnsafeCoercion t1 t2) = + (sep [pqname unsafeCoercion, paty t1, paty t2]) +pty (LeftCoercion t) = + (pqname leftCoercion <+> paty t) +pty (RightCoercion t) = + (pqname rightCoercion <+> paty t) pty t = pbty t pappty (Tapp t1 t2) ts = pappty t1 (t2:ts) -- 1.7.10.4