rachel/gecco
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

wtf is this

Browse Source
This commit is contained in:
Rachel Lambda Samuelsson 2024-06-10 18:04:10 +02:00
parent eab8d23e70
commit c986d42bf2
1 changed files with 28 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
src/Parse.hs
View File

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