Core.hs

{-#LANGUAGE MultiParamTypeClasses #-}
module Text.Parcom.Core
( ParcomError (..)
, SourcePosition (..)
, ParcomT, parseT
, Parcom, parse
, peek, next, atEnd
, try, handle
, notFollowedBy
, (<?>), (<|>), empty
, Stream, Token
)
where

import qualified Text.Parcom.Stream as Stream
import Text.Parcom.Stream (Stream, Token)
import Control.Monad (liftM, ap)
import Control.Applicative
import Control.Monad.Identity
import Control.Monad.Trans.Class

data SourcePosition =
    SourcePosition
        { posFileName :: String
        , posLine :: Int
        , posColumn :: Int
        }
        deriving (Show)

data ParcomError =
    ParcomError
        { peErrorDescription :: String
        , peSourcePosition :: SourcePosition
        }
        deriving (Show)

data ParcomState s =
    ParcomState
        { psSourcePosition :: SourcePosition
        , psStream :: s
        }

type Parcom s t a = ParcomT s t Identity a
newtype ParcomT s t m a = ParcomT { runParcomT :: ParcomState s -> m (Either ParcomError a, ParcomState s) }

instance (Monad m) => Monad (ParcomT s t m) where
    return x = ParcomT (\s -> return (Right x, s))
    fail err = ParcomT (\s -> return (Left $ ParcomError err (psSourcePosition s), s))
    m >>= f = ParcomT $ \s -> do -- in the m Monad
        (a, s') <- runParcomT m s
        case a of
            Left err -> return (Left err, s')
            Right ma -> do
                runParcomT (f ma) s'

instance MonadTrans (ParcomT s t) where
    lift a = ParcomT $ \s -> do
        v <- a
        return (Right v, s)

instance (Monad m) => Functor (ParcomT s t m) where
    fmap f xs = xs >>= return . f

instance (Monad m) => Applicative (ParcomT s t m) where
    pure = return
    (<*>) = ap

instance (Monad m) => Alternative (ParcomT s t m) where
    (<|>) = alt
    empty = fail "empty"

runParserT :: (Stream s t, Token t) => ParcomT s t m a -> String -> s -> m (Either ParcomError a, ParcomState s)
runParserT p fn str =
    runParcomT p state
    where
        state =
            ParcomState
                { psSourcePosition = SourcePosition fn 1 1
                , psStream = str }

parseT :: (Stream s t, Token t, Monad m) => ParcomT s t m a -> String -> s -> m (Either ParcomError a)
parseT p fn str = fst `liftM` runParserT p fn str

parse :: (Stream s t, Token t) => Parcom s t a -> String -> s -> Either ParcomError a
parse p fn str = runIdentity $ parseT p fn str

getState :: Monad m => ParcomT s t m (ParcomState s)
getState = ParcomT $ \s -> return (Right s, s)

useState :: Monad m => (ParcomState s -> a) -> ParcomT s t m a
useState f = ParcomT $ \s -> return (Right $ f s, s)

setState :: Monad m => ParcomState s -> ParcomT s t m ()
setState s = ParcomT $ \_ -> return (Right (), s)

modifyState :: Monad m => (ParcomState s -> ParcomState s) -> ParcomT s t m ()
modifyState f = ParcomT $ \s -> return (Right (), f s)

-- | Very general error / success handler
-- Each of the error / success branches takes both the old and the new state,
-- so that the branch handler itself can decide whether to backtrack or
-- continue with the new state.
handle' :: Monad m
    => ParcomT s t m a
    -> (ParcomError -> ParcomState s -> ParcomState s -> m (Either ParcomError b, ParcomState s))
    -> (a -> ParcomState s -> ParcomState s -> m (Either ParcomError b, ParcomState s))
    -> ParcomT s t m b
handle' p errorH successH = ParcomT $ \s -> do
    (r, s') <- runParcomT p s
    case r of
        -- parse failed: run error handler
        Left e -> errorH e s s'
        -- parse succeeded: run success handler
        Right x -> successH x s s'

handle :: Monad m
    => ParcomT s t m a
    -> (ParcomError -> ParcomT s t m b)
    -> (a -> ParcomT s t m b)
    -> ParcomT s t m b
handle p f t =
    handle' p (\e _ s' -> runParcomT (f e) s') (\x _ s' -> runParcomT (t x) s')

handleB :: Monad m
    => ParcomT s t m a
    -> (ParcomError -> ParcomT s t m b)
    -> (a -> ParcomT s t m b)
    -> ParcomT s t m b
handleB p f t =
    handle' p (\e s _ -> runParcomT (f e) s) (\x s _ -> runParcomT (t x) s)

-- | Backtracking modifier; restores the parser state to the previous situation
-- if the wrapped parser fails.
try :: Monad m => ParcomT s t m a -> ParcomT s t m a
try p = handle' p (\e s _ -> return (Left e, s)) (\x _ s' -> return (Right x, s'))

-- | Return the result of the first parser that succeeds.
alt :: Monad m => ParcomT s t m a -> ParcomT s t m a -> ParcomT s t m a
alt a b = handle' a (\e s _ -> runParcomT b s) (\x _ s' -> return (Right x, s'))

-- | Succeeds iff the given parser fails
notFollowedBy :: (Monad m, Stream s t) => ParcomT s t m a -> ParcomT s t m ()
notFollowedBy p = handle' p (\_ s _ -> return (Right (), s)) (\x s _ -> runParcomT (fail "something followed that shouldn't") s)
    
-- | Gets the next token from the stream without consuming it.
-- Fails at end-of-input.
peek :: (Monad m, Stream s t) => ParcomT s t m t
peek = do
    str <- psStream `liftM` getState
    if Stream.atEnd str
        then fail "Unexpected end of input"
        else return (Stream.peek str)

-- | Checks whether end-of-input has been reached.
atEnd :: (Monad m, Stream s t) => ParcomT s t m Bool
atEnd = useState (Stream.atEnd . psStream)

nextLine :: SourcePosition -> SourcePosition
nextLine s =
    s { posLine = posLine s + 1, posColumn = 1 }

nextColumn :: SourcePosition -> SourcePosition
nextColumn s =
    s { posColumn = posColumn s + 1 }

-- | Gets the next token from the stream and consumes it.
-- Fails at end-of-input.
next :: (Monad m, Stream s t, Token t) => ParcomT s t m t
next = do
    str <- psStream `liftM` getState
    if Stream.atEnd str
        then fail "Unexpected end of input"
        else do
            let (t, str') = Stream.pop str
            modifyState $ \state -> state { psStream = str' }
            if Stream.isLineDelimiter t
                then modifyState $ \s -> s { psSourcePosition = nextLine (psSourcePosition s) }
                else modifyState $ \s -> s { psSourcePosition = nextColumn (psSourcePosition s) }
            return t

(<?>) :: (Monad m, Stream s t) => ParcomT s t m a -> String -> ParcomT s t m a
p <?> expected = p <|> fail ("Expected " ++ expected)