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
import Maybe
import Control.Monad.Reader
+-- just for printing warnings
+import System.IO.Unsafe
import Core
import Printer()
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
("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)
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
-- 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
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"
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")
-{-# OPTIONS -Wall -Werror -fno-warn-missing-signatures #-}
+{-# OPTIONS -Wall -fno-warn-missing-signatures #-}
-module ParsecParser where
+module ParsecParser (parseCore) where
import Core
import ParseGlue
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)
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!
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
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
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
coreNonrecVdef = coreVdef >>= (return . Nonrec)
coreVdef = do
- (vdefLhs, vdefTy) <- topVbind
+ (vdefLhs, vdefTy) <- try topVbind <|> (do
+ (v, ty) <- lambdaBind
+ return (unqual v, ty))
whiteSpace
symbol "="
whiteSpace
-- 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
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))
coreAtTbind = (symbol "@") >> coreTbind
+topVbind :: Parser (Qual Var, Ty)
topVbind = aCoreVbind coreQualifiedName
+lambdaBind :: Parser (Var, Ty)
lambdaBind = aCoreVbind identifier
aCoreVbind idP = do
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
, caseSensitive = True
}
+{-
-- Stuff to help with testing in ghci.
pTest (Left a) = error (show a)
pTest (Right t) = print t
p <- a
symbol b
return p
+-}
\ No newline at end of file
shows (text "<C" <+> 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...
-- 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:
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])
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)
projects / ghc-hetmet.git / commitdiff