wtf is this

This commit is contained in:
Rachel Lambda Samuelsson 2024-06-10 18:04:10 +02:00
parent eab8d23e70
commit c986d42bf2

View File

@ -10,6 +10,7 @@ import Data.Text (Text, unpack)
import Data.Char (isLetter, isSpace)
import Data.List (elemIndex)
import Control.Applicative ((<|>))
import Control.Monad (guard)
import Syn
@ -28,15 +29,16 @@ 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 ')')
ns :: Parser a -> Parser a
ns = between skipSpace skipSpace
opTable :: [[Operator Parser Syn]]
opTable =
[ [ prefix "!" Not
@ -59,45 +61,31 @@ opTable =
binary :: Text -> (Syn -> Syn -> Syn) -> Operator Parser Syn
binary name f = InfixL (f <$ chunk name)
prefix, postfix :: Text -> (Syn -> Syn) -> Operator Parser Syn
prefix :: 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
parseSyn ctx = ns (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
l <- many (try (ns goL))
r <- many (try (ns goR))
let lr = l ++ r
guard (not (null lr))
pure (foldl1 App lr)
where
go = choice [ parseFix ctx
, parseIf ctx
, parseLam ctx
, parseLet ctx
, parseIL
goL = choice [ parseIL
, parseBL
, parseUL
, parseVar ctx
, try (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
goR = choice [ parseIf ctx
, parseLam ctx
, parseLet ctx
]
parseId :: Parser String
parseId = unpack <$> P.takeWhile1P Nothing isLetter
@ -113,23 +101,14 @@ 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
parseType = ns (makeExprParser (ns parseInnerType) [[ InfixR (Fun <$ chunk "->") ]])
parseInnerType :: Parser Ty
parseInnerType = choice [ chunk "Unit" >> pure Unit
, chunk "Int" >> pure Int
, chunk "Bool" >> pure Bool
, parens parseType
]
parseLet :: Ctx -> Parser Syn
parseLet ctx = do
@ -181,9 +160,3 @@ parseIf ctx = do
skipSpace
b <- parseSyn ctx
pure (If p a b)
parseFix :: Ctx -> Parser Syn
parseFix ctx = do
chunk "fix"
skipSpace
Fix <$> parseSyn ctx