Initial WIP

1 files changed, 137 insertions, 0 deletions

diff --git a/Parser.hs b/Parser.hs
new file mode 100644
index 0000000..420e2b8
--- /dev/null
+++ b/Parser.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE LambdaCase #-}
+module Parser where
+
+import Control.Applicative
+import Data.Char (isSpace)
+import Control.Monad.Chronicle
+import Control.Monad.Reader
+import Control.Monad.State.Strict
+import Data.Foldable (asum)
+import Data.These
+
+import AST
+
+
+-- Positions are zero-based in both dimensions
+data PS = PS
+    { psRefCol :: Int
+    , psLine :: Int
+    , psCol :: Int
+    , psRest :: String }
+  deriving (Show)
+
+data Context = Context { ctxFile :: FilePath }
+  deriving (Show)
+
+type Parser = ReaderT Context (ChronicleT [ErrMsg] (State PS))
+
+-- Positions are zero-based in both dimensions
+data ErrMsg = ErrMsg { errFile :: FilePath
+                     , errLine :: Int
+                     , errCol :: Int
+                     , errMsg :: String }
+  deriving (Show)
+
+printErrMsg :: ErrMsg -> String
+printErrMsg (ErrMsg fp y x s) = fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s
+
+parse :: FilePath -> String -> These [ErrMsg] (Program ())
+parse fp source =
+    flip evalState (PS 0 0 0 source)
+    . runChronicleT
+    . flip runReaderT (Context fp)
+    $ pProgram
+                            
+pProgram :: Parser (Program ())
+pProgram = do
+    prog <- Program <$> many pFunDef
+    skipWhiteComment
+    assertEOF Error
+    return prog
+
+pFunDef :: Parser (FunDef ())
+pFunDef = _
+
+
+
+data Fatality = Error | Fatal
+  deriving (Show)
+
+raise :: Fatality -> String -> Parser ()
+raise fat msg = do
+    fp <- asks ctxFile
+    ps <- get
+    let fun = case fat of
+                Error -> dictate . pure
+                Fatal -> confess . pure
+    fun (ErrMsg fp (psLine ps) (psCol ps) msg)
+
+assertEOF :: Fatality -> Parser ()
+assertEOF fat = gets psRest >>= \case
+    [] -> return ()
+    _ -> raise fat "Unexpected stuff"
+
+data ReadResult a = Token a | Truncated a
+  deriving (Show, Functor)
+
+readInline :: (s -> Char -> Maybe s) -> s -> Parser (ReadResult String)
+readInline f s0 = do
+    ps0 <- get
+    when (psCol ps0 <= psRefCol ps0) $
+        raise Fatal "Expected stuff, but found end of indented expression"
+    let loop :: (s -> Char -> Maybe s) -> s -> Parser (ReadResult String)
+        loop f' st = do
+            ps <- get
+            case psRest ps of
+              c : cs | Just st' <- f' st c -> do
+                         put (ps { psCol = psCol ps + 1, psRest = cs })
+                         fmap (c :) <$> loop f' st'
+                     | otherwise -> return (Token "")
+              [] -> return (Truncated "")
+    loop f s0
+
+skipWhiteComment :: Parser ()
+skipWhiteComment = do
+    inlineWhite
+    _ <- many (inlineComment >> inlineWhite)
+    _ <- optional lineComment
+    (consumeNewline >> skipWhiteComment) <|> return ()
+  where
+    inlineWhite :: Parser ()
+    inlineWhite = readWhileInline isSpace
+
+    inlineComment :: Parser ()
+    inlineComment = do
+        string "{-"
+        let loop = do
+                readWhileInline (`notElem` "{-")
+                asum [string "-}"
+                     ,inlineComment >> loop
+                     ,consumeNewline >> loop]
+        loop
+
+    lineComment :: Parser ()
+    lineComment = string "--" >> readWhileInline (const True)
+
+    readWhileInline :: (Char -> Bool) -> Parser ()
+    readWhileInline p = do
+        (taken, rest) <- span (\c -> p c && c /= '\n') <$> gets psRest
+        modify (\ps -> ps { psCol = psCol ps + length taken
+                          , psRest = rest })
+
+consumeNewline :: Parser ()
+consumeNewline = gets psRest >>= \case
+    '\n' : rest -> modify (\ps -> ps { psLine = psLine ps + 1
+                                     , psCol = 0
+                                     , psRest = rest })
+    _ -> empty
+
+string :: String -> Parser ()
+string s | any (== '\n') s = error "Newline in 'string' argument"
+string s = do
+    ps <- get
+    if take (length s) (psRest ps) == s
+        then put (ps { psCol = psCol ps + length s
+                     , psRest = drop (length s) (psRest ps) })
+        else empty