parsing is hard :(

This commit is contained in:
Rachel Lambda Samuelsson 2024-06-10 17:30:40 +02:00
parent f8503b3cd8
commit eab8d23e70
4 changed files with 194 additions and 1 deletions

1
fib.ss
View File

@ -1 +0,0 @@
(define fix (lambda (f)((lambda (x) (f (lambda (a) ((x x) a))))(lambda (x) (f (lambda (a) ((x x) a)))))))(fix (lambda (x0) (lambda (x1) (if (> 2 x1) 1 (+ (x0 (- x1 1)) (x0 (- x1 2)))))))

View File

@ -25,9 +25,13 @@ library
, Syn
, Eval
, Type
, Parse
, TestProg
, CompChez
build-depends: base
, megaparsec
, parser-combinators
, text
hs-source-dirs: src
default-language: GHC2021
default-extensions: LambdaCase

189
src/Parse.hs Normal file
View File

@ -0,0 +1,189 @@
{-# LANGUAGE OverloadedStrings #-}
module Parse where
import Text.Megaparsec as P
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Control.Monad.Combinators.Expr
import Data.Text (Text, unpack)
import Data.Char (isLetter, isSpace)
import Data.List (elemIndex)
import Control.Applicative ((<|>))
import Syn
type Ctx = [String]
type Parser = Parsec Text Text
instance ShowErrorComponent Text where
showErrorComponent = unpack
skipSpace :: Parser ()
skipSpace = L.space space1 (L.skipLineComment "--") (L.skipBlockComment "{-" "-}")
parseExpr :: Text -> Either (ParseErrorBundle Text Text) Syn
parseExpr = parse (parser []) "<FILE>"
parser :: Ctx -> Parser Syn
parser ctx = do
skipSpace
res <- parseSyn ctx
skipSpace
eof
pure res
parens :: Parser a -> Parser a
parens = between (single '(') (single ')')
opTable :: [[Operator Parser Syn]]
opTable =
[ [ prefix "!" Not
, prefix "fix" Fix
]
, [ binary "*" Mul
, binary "/" Div
, binary "%" Mod
, binary "&&" And
]
, [ binary "+" Add
, binary "-" Sub
, binary "||" Or
]
, [ binary "==" Equal
, binary ">" Great
]
]
binary :: Text -> (Syn -> Syn -> Syn) -> Operator Parser Syn
binary name f = InfixL (f <$ chunk name)
prefix, postfix :: Text -> (Syn -> Syn) -> Operator Parser Syn
prefix name f = Prefix (f <$ chunk name)
postfix name f = Postfix (f <$ chunk name)
parseSyn :: Ctx -> Parser Syn
parseSyn ctx = makeExprParser (parseInnerSyn ctx) opTable
parseInnerSyn :: Ctx -> Parser Syn
parseInnerSyn ctx = do
skipSpace
f <- go
skipSpace
(do
x <- try go
skipSpace
pure (App f x)) <|> pure f
where
go = choice [ parseFix ctx
, parseIf ctx
, parseLam ctx
, parseLet ctx
, parseIL
, parseBL
, parseUL
, parseVar ctx
, parens (parseSyn ctx)
]
parseOp :: Text -> Parser Syn -> (Syn -> Syn -> Syn) -> Parser Syn
parseOp name par op = do
a <- par
(do
skipSpace
chunk name
skipSpace
op a <$> par)
<|> pure a
parseId :: Parser String
parseId = unpack <$> P.takeWhile1P Nothing isLetter
parseIL :: Parser Syn
parseIL = IL <$> L.signed skipSpace (L.lexeme skipSpace L.decimal)
parseUL :: Parser Syn
parseUL = chunk "unit" >> pure UL
parseBL :: Parser Syn
parseBL = (chunk "true" >> pure (BL True))
<|> (chunk "false" >> pure (BL False))
parseType :: Parser Ty
parseType = parseFun
<|> parseType1
parseType1 :: Parser Ty
parseType1 = (chunk "Unit" >> pure Unit)
<|> (chunk "Int" >> pure Int)
<|> (chunk "Bool" >> pure Bool)
<|> parens parseType
parseFun :: Parser Ty
parseFun = do
ty1 <- parseType1
skipSpace
chunk "->"
skipSpace
Fun ty1 <$> parseType
parseLet :: Ctx -> Parser Syn
parseLet ctx = do
chunk "let"
skipSpace
name <- parseId
skipSpace
single ':'
skipSpace
ty <- parseType
skipSpace
single '='
skipSpace
tr <- parseSyn ctx
skipSpace
chunk "in"
skipSpace
body <- parseSyn (name : ctx)
pure (Let ty tr body)
parseVar :: Ctx -> Parser Syn
parseVar ctx = do
name <- parseId
case elemIndex name ctx of
Just i -> pure (Var i)
_ -> fail ("unbound identifier: " ++ show name)
parseLam :: Ctx -> Parser Syn
parseLam ctx = do
single '\\'
skipSpace
name <- parseId
skipSpace
single '.'
skipSpace
Lam <$> parseSyn (name : ctx)
parseIf :: Ctx -> Parser Syn
parseIf ctx = do
chunk "if"
skipSpace
p <- parseSyn ctx
skipSpace
chunk "then"
skipSpace
a <- parseSyn ctx
skipSpace
chunk "else"
skipSpace
b <- parseSyn ctx
pure (If p a b)
parseFix :: Ctx -> Parser Syn
parseFix ctx = do
chunk "fix"
skipSpace
Fix <$> parseSyn ctx

View File

@ -55,6 +55,7 @@ infer ctx tr = case tr of
Fix f -> infer ctx f >>= \case
Fun t1 t2 -> guard (t1 == t2) >> pure t1
_ -> Nothing
_ -> Nothing
where
checkOp :: Ctx -> Syn -> Syn -> Ty -> Ty -> Maybe Ty
checkOp ctx a b tyin tyout = do