diff --git a/bowtie-blueprint/src/Bowtie/Blueprint.hs b/bowtie-blueprint/src/Bowtie/Blueprint.hs index a1f5900..8bc3642 100644 --- a/bowtie-blueprint/src/Bowtie/Blueprint.hs +++ b/bowtie-blueprint/src/Bowtie/Blueprint.hs @@ -86,8 +86,8 @@ programTypesParser = do parseOne :: Parse.Parser Item parseOne = Mega.label "parseOne" - ( Mega.try (fmap (uncurry Decl) Parse.declEntryParser) - <|> Mega.try (fmap (uncurry Func) Parse.defParser) + ( Mega.try (fmap (uncurry Decl) Parse.typeDeclarationParser) + <|> Mega.try (fmap (uncurry Func) Parse.typeSignatureParser) ) -- * Markdown diff --git a/bowtie/src/Bowtie/Surface/Parse.hs b/bowtie/src/Bowtie/Surface/Parse.hs index 8ef9b37..9398776 100644 --- a/bowtie/src/Bowtie/Surface/Parse.hs +++ b/bowtie/src/Bowtie/Surface/Parse.hs @@ -14,8 +14,8 @@ import Bowtie.Lib.OrderedMap (OrderedMap) import Bowtie.Lib.Prelude hiding (many, some) import Bowtie.Surface.AST import Bowtie.Type.Parse - (Parser, ParserErrorBundle, lexeme, lowerIdParser, parseTest, - spacesOrNewlines, symbol, upperIdParser) + (Parser, ParserErrorBundle, lexeme, lowerIbindingParser, parseTest, + spacesOrNewlines, symbol, upperIbindingParser) import Control.Applicative.Combinators.NonEmpty import Text.Megaparsec hiding (parse, parseTest, some) @@ -46,12 +46,12 @@ sourceParser = do -- entries <- -- many $ try $ do -- _ <- Lexer.indentGuard spacesOrNewlines EQ pos1 - -- entryParser + -- declarationParser _ <- Lexer.indentGuard spacesOrNewlines EQ pos1 entries <- many do - e <- entryParser + e <- declarationParser -- TODO: ensure that we actually did get an eof at the end of the list void (Lexer.indentGuard spacesOrNewlines EQ pos1) <|> eof pure e @@ -70,34 +70,36 @@ sourceParser = do Right a -> pure a -entryParser :: Parser AST -entryParser = - label "entryParser" - ( fmap (\(i,d) -> AST (OrderedMap.singleton i d) OrderedMap.empty) Type.declEntryParser - <|> fmap (\(i,e,typ) -> AST OrderedMap.empty (OrderedMap.singleton i (e, typ))) dParser +declarationParser :: Parser AST +declarationParser = + label "declarationParser" + ( fmap (\(i,d) -> AST (OrderedMap.singleton i d) OrderedMap.empty) Type.typeDeclarationParser + <|> fmap (\(i,e,typ) -> AST OrderedMap.empty (OrderedMap.singleton i (e, typ))) bindingParser ) -- | --- >>> parseTest dParser "a : Int\na =\n 1" +-- >>> parseTest bindingParser "a : Int\na =\n 1" -- (Id "a",IntLiteral 1,TConstructor (Id "Int")) -dParser :: Parser (Id, Expr, Type) -dParser = do +-- +-- Parses value declarations as well. +bindingParser :: Parser (Id, Expr, Type) +bindingParser = do pos <- Lexer.indentLevel - (id, typ) <- Type.defParser + (id, typ) <- Type.typeSignatureParser _ <- Lexer.indentGuard spacesOrNewlines EQ pos - (id2, expr) <- valDefParser + (id2, expr) <- bindingBodyParser when (id /= id2) (fail (Text.unpack ("Type and term IDs don't match: " <> unId id <> " " <> unId id2))) pure (id, expr, typ) -- | --- >>> parseTest valDefParser "a =\n 1" +-- >>> parseTest bindingBodyParser "a =\n 1" -- (Id "a",IntLiteral 1) -valDefParser :: Parser (Id, Expr) -valDefParser = do +bindingBodyParser :: Parser (Id, Expr) +bindingBodyParser = do pos <- Lexer.indentLevel - i <- lexeme lowerIdParser + i <- lexeme lowerIbindingParser symbol "=" _ <- Lexer.indentGuard spacesOrNewlines GT pos e <- exprParser @@ -119,7 +121,7 @@ lamParser :: Parser Expr lamParser = do pos <- Lexer.indentLevel symbol "\\" - id <- lexeme lowerIdParser + id <- lexeme lowerIbindingParser mType <- optional annotationParser symbol "." _ <- Lexer.indentGuard spacesOrNewlines GT pos @@ -147,7 +149,7 @@ letParser = do p :: Parser (Lexer.IndentOpt Parser (OrderedMap Id (Expr, Type)) (Id, Expr, Type)) p = do symbol "let" - pure (Lexer.IndentSome Nothing g dParser) + pure (Lexer.IndentSome Nothing g bindingParser) g :: [(Id, Expr, Type)] -> Parser (OrderedMap Id (Expr, Type)) g decls = @@ -184,8 +186,8 @@ caseParser = altParser :: Parser Alt altParser = do pos <- Lexer.indentLevel - i <- lexeme upperIdParser - ids <- many (lexeme lowerIdParser) + i <- lexeme upperIbindingParser + ids <- many (lexeme lowerIbindingParser) symbol "->" _ <- Lexer.indentGuard spacesOrNewlines GT pos e <- exprParser @@ -218,11 +220,11 @@ itemParser = varParser :: Parser Expr varParser = - fmap Var (lexeme lowerIdParser) + fmap Var (lexeme lowerIbindingParser) conParser :: Parser Expr conParser = - fmap Construct (lexeme upperIdParser) + fmap Construct (lexeme upperIbindingParser) -- | -- >>> parseTest intParser "1" diff --git a/bowtie/src/Bowtie/Type/Parse.hs b/bowtie/src/Bowtie/Type/Parse.hs index 99119ea..41fcd74 100644 --- a/bowtie/src/Bowtie/Type/Parse.hs +++ b/bowtie/src/Bowtie/Type/Parse.hs @@ -1,11 +1,11 @@ module Bowtie.Type.Parse ( Parser , ParserErrorBundle - , declEntryParser - , defParser + , typeDeclarationParser + , typeSignatureParser , typeParser - , lowerIdParser - , upperIdParser + , lowerIbindingParser + , upperIbindingParser -- | Helpers , lexeme @@ -53,18 +53,18 @@ type ParserErrorBundle = ParseErrorBundle Text Void -- ]) -- ) -- --- >>> parseTest declEntryParser "type Foo a b = Bar Bool a | Baz Int b" +-- >>> parseTest typeDeclarationParser "type Foo a b = Bar Bool a | Baz Int b" -- (Id "Foo",TypeDeclaration [Id "a",Id "b"] (OrderedMap (fromList [(Id "Baz",(1,[TConstructor (Id "Int"),TVariable (Id "b")])),(Id "Bar",(0,[TConstructor (Id "Bool"),TVariable (Id "a")]))]) (fromList [(0,(Id "Bar",[TConstructor (Id "Bool"),TVariable (Id "a")])),(1,(Id "Baz",[TConstructor (Id "Int"),TVariable (Id "b")]))]))) -- -- ^^ TODO: OrderedMaps do not do well with Show -declEntryParser :: Parser (Id, TypeDeclaration) -declEntryParser = do +typeDeclarationParser :: Parser (Id, TypeDeclaration) +typeDeclarationParser = do -- Note that we don't parse a @Break@ here. If each top level -- parser started with Break it would actually have to be -- @try (toss Break)@ so they wouldn't step on each other's toes. symbol "type" - typeId <- lexeme upperIdParser - typeArgs <- many (lexeme lowerIdParser) + typeId <- lexeme upperIbindingParser + typeArgs <- many (lexeme lowerIbindingParser) symbol "=" constructors <- constructorParser `sepBy` symbol "|" case OrderedMap.fromList constructors of @@ -79,7 +79,7 @@ declEntryParser = do -- (Id "Bar",[TConstructor (Id "Bool"),TVariable (Id "a")]) constructorParser :: Parser (Id, [Type]) constructorParser = do - id <- lexeme upperIdParser + id <- lexeme upperIbindingParser args <- many constructorArgParser pure (id, args) @@ -103,11 +103,11 @@ constructorArgParser = ) -- | --- >>> parseTest defParser "foo : Int -> a" +-- >>> parseTest typeSignatureParser "foo : Int -> a" -- (Id "foo",TArrow (TConstructor (Id "Int")) (TVariable (Id "a"))) -defParser :: Parser (Id, Type) -defParser = do - i <- lexeme lowerIdParser +typeSignatureParser :: Parser (Id, Type) +typeSignatureParser = do + i <- lexeme lowerIbindingParser symbol ":" t <- typeParser pure (i, t) @@ -160,18 +160,18 @@ singleTypeParser = do singleTypeParser' :: Parser Type singleTypeParser' = -- TODO: a good label - fmap TVariable (lexeme lowerIdParser) - <|> fmap TConstructor (lexeme upperIdParser) + fmap TVariable (lexeme lowerIbindingParser) + <|> fmap TConstructor (lexeme upperIbindingParser) -- | --- >>> parseTest lowerIdParser "a" +-- >>> parseTest lowerIbindingParser "a" -- Id "a" -- -- When we had a separate lexer this could just be tried after trying -- to lex keyword tokens like "let" and "in". Now that we don't -- it needs logic so that it doesn't eat those keywords. -lowerIdParser :: Parser Id -lowerIdParser = do +lowerIbindingParser :: Parser Id +lowerIbindingParser = do notFollowedBy (keyword *> satisfy (not . validIdChar)) c <- satisfy Char.isLower rest <- takeWhileP (Just "followup identifier char") validIdChar @@ -192,10 +192,10 @@ keywordList = ] -- | --- >>> parseTest upperIdParser "Unit" +-- >>> parseTest upperIbindingParser "Unit" -- Id "Unit" -upperIdParser :: Parser Id -upperIdParser = do +upperIbindingParser :: Parser Id +upperIbindingParser = do c <- satisfy Char.isUpper rest <- takeWhileP (Just "followup identifier char") validIdChar pure (Id (Text.cons c rest))