diff options
| -rw-r--r-- | Parser.hs | 104 |
1 files changed, 86 insertions, 18 deletions
@@ -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 +parse fp source = fmap snd $ runParser pProgram (Context fp) (PS 0 0 0 source) -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 - 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 |