-module ParsecParser where
+{-# OPTIONS -Wall -fno-warn-missing-signatures #-}
+
+module ParsecParser (parseCore) where
import Core
import ParseGlue
+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)
pkgName <- corePackageName
char ':'
(modHierarchy,baseName) <- coreHierModuleNames
- return (pkgName, modHierarchy, baseName)
+ return $ M (pkgName, modHierarchy, baseName)
corePackageName :: Parser Pname
-corePackageName = identifier
+-- Package names can be lowercase or uppercase!
+corePackageName = identifier <|> upperName
coreHierModuleNames :: Parser ([Id], Id)
coreHierModuleNames = do
reserved "newtype"
tyCon <- coreQualifiedCon
whiteSpace
+ coercionName <- coreQualifiedCon
+ whiteSpace
tBinds <- coreTbinds
- symbol "^"
- axiom <- coreAxiom
tyRep <- try coreTRep
- return $ Newtype tyCon tBinds axiom tyRep
+ return $ Newtype tyCon coercionName tBinds tyRep
coreQualifiedCon :: Parser (Mname, Id)
coreQualifiedCon = coreQualifiedGen upperName
-
+
coreQualifiedName = coreQualifiedGen identifier
-coreQualifiedGen p = do
- maybeMname <- coreMaybeMname
- theId <- p
- return (maybeMname, theId)
-
-coreMaybeMname = optionMaybe coreMname
-
-coreRequiredQualifiedName = do
- mname <- coreMname
- theId <- identifier
- 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
- coercionName <- coreQualifiedCon
- whiteSpace
- symbol "::"
- whiteSpace
- coercionKind <- coreKind
- return (coercionName, coercionKind))
+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)))
coreTbinds :: Parser [Tbind]
coreTbinds = many coreTbind
tBinds <- try $ coreTbindsGen (symbol "@")
-- This should be equivalent to (many coreAty)
-- But it isn't. WHY??
- tys <- sepBy coreAty whiteSpace
+ tys <- sepBy coreAtySaturated whiteSpace
return $ Constr dataConName tBinds tys
coreTRep :: Parser (Maybe Ty)
stuff -> foldl Tapp (Tcon tcArrow) (hd:stuff))
coreBty :: Parser Ty
-coreBty = arrowThing coreAty coreAty whiteSpace Tapp
-
-arrowThing :: Parser a -> Parser a -> Parser b -> (a -> a -> a) -> Parser a
-arrowThing hdThing restThing sep op = do
- hd <- hdThing
+coreBty = do
+ hd <- coreAty
-- The "try" is necessary:
-- otherwise, parsing "T " fails rather
-- than returning "T".
- maybeRest <- option [] (many1 (try (sep >> restThing)))
- return $ case maybeRest of
- [] -> hd
- stuff -> foldl op hd maybeRest
-
-coreAppTy :: Parser Ty
-coreAppTy = do
- bTy <- try coreBty
- whiteSpace
- aTy <- try coreAty
- return $ Tapp bTy aTy
-
-coreAty = try coreTcon <|> try coreTvar <|> parens coreType
-
+ maybeRest <- option [] (many1 (try (whiteSpace >> coreAtySaturated)))
+ return $ (case hd of
+ -- so I'm not sure I like this... it's basically doing
+ -- typechecking (kind-checking?) in the parser.
+ -- However, the type syntax as defined in Core.hs sort of
+ -- forces it.
+ ATy t -> foldl Tapp t maybeRest
+ Trans k -> app k 2 maybeRest "trans"
+ Sym k -> app k 1 maybeRest "sym"
+ Unsafe k -> app k 2 maybeRest "unsafe"
+ LeftCo k -> app k 1 maybeRest "left"
+ RightCo k -> app k 1 maybeRest "right"
+ InstCo k -> app k 2 maybeRest "inst")
+ where app k arity args _ | length args == arity = k args
+ app _ _ args err =
+ primCoercionError (err ++
+ ("Args were: " ++ show args))
+
+coreAtySaturated :: Parser Ty
+coreAtySaturated = do
+ t <- coreAty
+ case t of
+ ATy ty -> return ty
+ _ -> unexpected "coercion ty"
+
+coreAty :: Parser ATyOp
+coreAty = try coreTcon <|> ((try coreTvar <|> parens coreType)
+ >>= return . ATy)
coreTvar :: Parser Ty
coreTvar = try identifier >>= (return . Tvar)
-coreTcon :: Parser Ty
+coreTcon :: Parser ATyOp
-- TODO: Change the grammar
-- A Tcon can be an uppercase type constructor
-- or a lowercase (always qualified) coercion variable
-coreTcon = (try coreQualifiedCon <|> coreRequiredQualifiedName)
- >>= (return . Tcon)
-
-coreTyApp :: Parser Ty
-coreTyApp = do
- operTy <- coreType
- randTy <- coreType
- return $ Tapp operTy randTy
-
-coreFunTy :: Parser Ty
-coreFunTy = do
- argTy <- coreBty
- whiteSpace
- symbol "->"
- whiteSpace
- resTy <- coreType
- return $ tArrow argTy resTy
+coreTcon =
+ -- Special case is first so that (CoUnsafe .. ..) gets parsed as
+ -- a prim. coercion app and not a Tcon app.
+ -- But the whole thing is so bogus.
+ try (do
+ -- the "try"s are crucial; they force
+ -- backtracking
+ maybeCoercion <- choice [try symCo, try transCo, try unsafeCo,
+ try instCo, try leftCo, rightCo]
+ return $ case maybeCoercion of
+ TransC -> Trans (\ [x,y] -> TransCoercion x y)
+ SymC -> Sym (\ [x] -> SymCoercion x)
+ UnsafeC -> Unsafe (\ [x,y] -> UnsafeCoercion x y)
+ LeftC -> LeftCo (\ [x] -> LeftCoercion x)
+ RightC -> RightCo (\ [x] -> RightCoercion x)
+ InstC -> InstCo (\ [x,y] -> InstCoercion x y))
+ <|> (coreQualifiedCon >>= (return . ATy . Tcon))
+
+data CoercionTy = TransC | InstC | SymC | UnsafeC | LeftC | RightC
+
+symCo, transCo, unsafeCo, instCo, leftCo, rightCo :: 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
+instCo = string "ghczmprim:GHCziPrim.inst" >> return InstC
coreForallTy :: Parser Ty
coreForallTy = do
coreKind = do
hd <- coreAtomicKind
maybeRest <- option [] (many1 (symbol "->" >> coreKind))
- return $ case maybeRest of
- [] -> hd
- stuff -> foldl Karrow hd maybeRest
+ return $ foldl Karrow hd maybeRest
coreAtomicKind = try liftedKind <|> try unliftedKind
- <|> try openKind <|> try (parens equalityKind)
+ <|> try openKind <|> try (do
+ (from,to) <- parens equalityKind
+ return $ Keq from to)
<|> try (parens coreKind)
liftedKind = do
ty1 <- coreBty
symbol ":=:"
ty2 <- coreBty
- return $ Keq ty1 ty2
+ return (ty1, ty2)
+
+-- Only used internally within the parser:
+-- represents either a Tcon, or a continuation
+-- for a primitive coercion
+data ATyOp =
+ ATy Ty
+ | Trans ([Ty] -> Ty)
+ | Sym ([Ty] -> Ty)
+ | Unsafe ([Ty] -> Ty)
+ | LeftCo ([Ty] -> Ty)
+ | RightCo ([Ty] -> Ty)
+ | InstCo ([Ty] -> Ty)
+
coreVdefGroups :: Parser [Vdefg]
coreVdefGroups = option [] (do
theFirstVdef <- coreVdefg
coreNonrecVdef = coreVdef >>= (return . Nonrec)
coreVdef = do
- (vdefLhs, vdefTy) <- topVbind
+ (vdefLhs, vdefTy) <- try topVbind <|> (do
+ (v, ty) <- lambdaBind
+ return (unqual v, ty))
whiteSpace
symbol "="
whiteSpace
coreAtomicExp :: Parser Exp
coreAtomicExp = do
-- For stupid reasons, the whiteSpace is necessary.
--- Without it, (pt coreAppExp "w ^a:B.C ") doesn't work.
+-- 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 res
coreFullExp = (choice [coreLam, coreLet,
- coreCase, coreCast, coreNote, coreExternal]) <|> (try coreAppExp)
+ coreCase, coreCast, coreNote, coreExternal, coreLabel]) <|> (try coreAppExp)
-- The "try" is necessary so that we backtrack
-- when we see a var (that is not an app)
<|> coreAtomicExp
args <- many1 (whiteSpace >> ((coreAtomicExp >>= (return . Left)) <|>
-- note this MUST be coreAty, not coreType, because otherwise:
-- "A @ B c" gets parsed as "A @ (B c)"
- ((symbol "@" >> coreAty) >>= (return . Right))))
+ ((symbol "@" >> coreAtySaturated) >>= (return . Right))))
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))
return $ Let vdefg body
coreCase = do
reserved "case"
- ty <- coreAty
+ ty <- coreAtySaturated
scrut <- coreAtomicExp
reserved "of"
vBind <- parens lambdaBind
-- The parens are CRUCIAL, o/w it's ambiguous
body <- try (parens coreFullExp)
whiteSpace
- ty <- try coreAty
+ ty <- try coreAtySaturated
return $ Cast body ty
coreNote = do
reserved "note"
s <- stringLiteral
e <- coreFullExp
return $ Note s e
-coreExternal = do
+coreExternal = (do
reserved "external"
-- TODO: This isn't in the grammar, but GHC
-- always prints "external ccall". investigate...
symbol "ccall"
s <- stringLiteral
- t <- coreAty
- return $ External s t
+ t <- coreAtySaturated
+ return $ External s t) <|>
+ -- TODO: I don't really understand what this does
+ (do
+ reserved "dynexternal"
+ symbol "ccall"
+ t <- coreAtySaturated
+ return $ External "[dynamic]" t)
+coreLabel = do
+-- TODO: Totally punting this, but it needs to go in the grammar
+-- or not at all
+ reserved "label"
+ s <- stringLiteral
+ return $ External s tAddrzh
coreLambdaBinds = many1 coreBind
coreAtTbind = (symbol "@") >> coreTbind
+topVbind :: Parser (Qual Var, Ty)
topVbind = aCoreVbind coreQualifiedName
+lambdaBind :: Parser (Var, Ty)
lambdaBind = aCoreVbind identifier
aCoreVbind idP = do
intOrRatLit = do
-- Int and lit combined into one to avoid ambiguity.
-- Argh....
- lhs <- anIntLit
+ lhs <- intLit
maybeRhs <- optionMaybe (symbol "%" >> anIntLit)
case maybeRhs of
Nothing -> return $ Lint lhs
Just rhs -> return $ Lrational (lhs % rhs)
+intLit :: Parser Integer
+intLit = anIntLit <|> parens anIntLit
+
anIntLit :: Parser Integer
anIntLit = do
sign <- option 1 (symbol "-" >> return (-1))
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
projects / ghc-hetmet.git / blobdiff