From a06d17e5f4ec8f5011f9ef264bd15d7e4a19c1fb Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sat, 27 Nov 2021 00:21:49 +0100
Subject: Work

---
 Parser.hs | 106 +++++++++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 87 insertions(+), 19 deletions(-)

diff --git a/Parser.hs b/Parser.hs
index f525ba6..4a37134 100644
--- a/Parser.hs
+++ b/Parser.hs
@@ -1,14 +1,20 @@
-{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
 module Parser where
 
 import Control.Applicative
-import Data.Char
 import Control.Monad.Chronicle
 import Control.Monad.Reader
-import Control.Monad.State.Strict
+import Control.Monad.State.Lazy
+import Data.Bifunctor (first)
+import Data.Char
 import Data.Foldable (asum)
 import Data.These
+import Data.Tuple (swap)
+
+import Debug.Trace
 
 import AST
 
@@ -24,7 +30,62 @@ data PS = PS
 data Context = Context { ctxFile :: FilePath }
   deriving (Show)
 
-type Parser = ReaderT Context (ChronicleT [ErrMsg] (State PS))
+-- ReaderT Context (ChronicleT [ErrMsg] (State PS) a)
+-- Context -> ChronicleT [ErrMsg] (State PS) a
+-- Context -> State PS (These [ErrMsg] a)
+-- Context -> PS -> Identity (These [ErrMsg] a, PS)
+-- Context -> PS -> (These [ErrMsg] a, PS)
+-- whereas I want:
+-- Context -> PS -> These [ErrMsg] (a, PS)
+-- which is not any transformer stack, but a new monad.
+newtype Parser a = Parser { runParser :: Context -> PS -> These [ErrMsg] (PS, a) }
+
+instance Functor Parser where
+    fmap f (Parser g) = Parser (\ctx ps -> fmap (fmap f) (g ctx ps))
+
+instance Applicative Parser where
+    pure x = Parser (\_ ps -> That (ps, x))
+    (<*>) = ap
+
+instance Monad Parser where
+    Parser g >>= f = Parser $ \ctx ps ->
+        case g ctx ps of
+          This errs -> This errs
+          That (ps', x) -> runParser (f x) ctx ps'
+          These errs (ps', x) -> case runParser (f x) ctx ps' of
+                                   This errs' -> This (errs <> errs')
+                                   That res -> These errs res
+                                   These errs' res -> These (errs <> errs') res
+
+instance Alternative Parser where
+    empty = Parser (\_ _ -> This mempty)
+    Parser f <|> Parser g = Parser $ \ctx ps ->
+        case f ctx ps of
+          This _ -> g ctx ps
+          success -> success
+
+instance MonadState PS Parser where
+    state f = Parser $ \_ ps -> That (swap (f ps))
+
+instance MonadReader Context Parser where
+    reader f = Parser $ \ctx ps -> That (ps, f ctx)
+    local f (Parser g) = Parser (g . f)
+
+instance MonadChronicle [ErrMsg] Parser where
+    dictate errs = Parser (\_ ps -> These errs (ps, ()))
+    confess errs = Parser (\_ _ -> This errs)
+    memento (Parser f) = Parser (\ctx ps -> case f ctx ps of
+                                              This errs -> That (ps, Left errs)
+                                              That res -> That (Right <$> res)
+                                              These errs res -> These errs (Right <$> res))
+    absolve def (Parser f) = Parser (\ctx ps -> case f ctx ps of
+                                                  This _ -> That (ps, def)
+                                                  success -> success)
+    condemn (Parser f) = Parser (\ctx ps -> case f ctx ps of
+                                              These errs _ -> This errs
+                                              res -> res)
+    retcon g (Parser f) = Parser (\ctx ps -> first g (f ctx ps))
+    chronicle th = Parser (\_ ps -> (ps,) <$> th)
 
 -- Positions are zero-based in both dimensions
 data ErrMsg = ErrMsg { errFile :: FilePath
@@ -37,15 +98,8 @@ printErrMsg :: ErrMsg -> String
 printErrMsg (ErrMsg fp y x s) = fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s
 
 parse :: FilePath -> String -> These [ErrMsg] (Program ())
-parse = runParser pProgram
-
-runParser :: Parser a -> FilePath -> String -> These [ErrMsg] a
-runParser p fp source = 
-    flip evalState (PS 0 0 0 source)
-    . runChronicleT
-    . flip runReaderT (Context fp)
-    $ p
-                            
+parse fp source = fmap snd $ runParser pProgram (Context fp) (PS 0 0 0 source)
+
 pProgram :: Parser (Program ())
 pProgram = do
     prog <- Program <$> many pFunDef
@@ -261,6 +315,7 @@ inlineWhite :: Parser ()
 inlineWhite = do
     skipWhiteComment
     ps <- get
+    TODO this check (and other similar checks) need to allow equality if the _line_ is also the reference starting line
     when (psCol ps <= psRefCol ps) empty
 
 -- | Consumes all whitespace and comments (including newlines). Note: this may
@@ -284,6 +339,7 @@ inlineComment = do
     let loop = do
             readWhileInline (`notElem` "{-")
             asum [string "-}"
+                 ,eof >> raise Error "Unfinished {- -} comment at end of file"
                  ,inlineComment >> loop
                  ,consumeNewline >> loop]
     loop
@@ -311,12 +367,19 @@ consumeNewline = gets psRest >>= \case
 
 -- | Consumes exactly one character, unequal to newline, at the current position.
 satisfy :: (Char -> Bool) -> Parser Char
-satisfy p = gets psRest >>= \case
-    c : rest | c /= '\n', p c -> do
-        modify (\ps -> ps { psCol = psCol ps + 1
-                          , psRest = rest })
-        return c
-    _ -> empty
+satisfy p = do
+    traceM "entering satisfy"
+    r <- gets psRest
+    traceM "got rest"
+    r `seq` return ()
+    traceM "seqd rest"
+    traceM ("rest is " ++ r)
+    case r of
+      c : rest | c /= '\n', p c -> do
+          modify (\ps -> ps { psCol = psCol ps + 1
+                            , psRest = rest })
+          return c
+      _ -> empty
 
 -- | Consumes exactly this string at the current position. The string must not
 -- contain a newline.
@@ -328,3 +391,8 @@ string s = do
         then put (ps { psCol = psCol ps + length s
                      , psRest = drop (length s) (psRest ps) })
         else empty
+
+-- | Only succeeds at EOF.
+eof :: Parser ()
+eof = gets psRest >>= \case [] -> return ()
+                            _ -> empty
-- 
cgit v1.2.3-70-g09d2