From eab8d23e703b2e9b04268fd30879a46cb5eacb53 Mon Sep 17 00:00:00 2001
From: Rachel Lambda Samuelsson <depsterr@protonmail.com>
Date: Mon, 10 Jun 2024 17:30:40 +0200
Subject: [PATCH] parsing is hard :(

---
 fib.ss       |   1 -
 gecco.cabal  |   4 ++
 src/Parse.hs | 189 +++++++++++++++++++++++++++++++++++++++++++++++++++
 src/Type.hs  |   1 +
 4 files changed, 194 insertions(+), 1 deletion(-)
 delete mode 100644 fib.ss
 create mode 100644 src/Parse.hs

diff --git a/fib.ss b/fib.ss
deleted file mode 100644
index c148ef9..0000000
--- a/fib.ss
+++ /dev/null
@@ -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)))))))
diff --git a/gecco.cabal b/gecco.cabal
index f746309..03edd7a 100644
--- a/gecco.cabal
+++ b/gecco.cabal
@@ -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
diff --git a/src/Parse.hs b/src/Parse.hs
new file mode 100644
index 0000000..e8f7217
--- /dev/null
+++ b/src/Parse.hs
@@ -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
diff --git a/src/Type.hs b/src/Type.hs
index 2e42b04..69e70f5 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -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