X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fext-core%2FParsecParser.hs;h=4afa9243c0501036584128093ac6fa579c1e2a17;hp=8602bdce7c207106c03df0a6f5f77d425a3e8d3d;hb=e4417dcd4679da9c6b18c02ff667199c572bed89;hpb=6e93da5e0a775b2bfb9c9f2bd31a36cc828521cb diff --git a/utils/ext-core/ParsecParser.hs b/utils/ext-core/ParsecParser.hs index 8602bdc..4afa924 100644 --- a/utils/ext-core/ParsecParser.hs +++ b/utils/ext-core/ParsecParser.hs @@ -1,12 +1,16 @@ -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) @@ -28,10 +32,11 @@ coreModuleName = do 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 @@ -75,45 +80,33 @@ coreNewtypeDecl = 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 @@ -145,7 +138,7 @@ coreCdef = do 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) @@ -168,52 +161,74 @@ coreType = coreForallTy <|> (do 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 @@ -228,12 +243,12 @@ coreKind :: Parser Kind 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 @@ -252,7 +267,20 @@ equalityKind = 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 @@ -270,7 +298,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 @@ -280,17 +310,16 @@ coreVdef = do 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 @@ -306,13 +335,17 @@ coreAppExp = do 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)) @@ -339,7 +372,7 @@ coreLet = do return $ Let vdefg body coreCase = do reserved "case" - ty <- coreAty + ty <- coreAtySaturated scrut <- coreAtomicExp reserved "of" vBind <- parens lambdaBind @@ -351,21 +384,33 @@ coreCast = do -- 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 @@ -376,7 +421,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 @@ -393,12 +440,15 @@ intOrRatLit :: Parser CoreLit 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)) @@ -448,7 +498,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 @@ -479,6 +528,7 @@ extCoreDef = LanguageDef { , caseSensitive = True } +{- -- Stuff to help with testing in ghci. pTest (Left a) = error (show a) pTest (Right t) = print t @@ -503,3 +553,4 @@ andThenSym a b = do p <- a symbol b return p +-} \ No newline at end of file