module Text.Parcom.Core
( ParcomError (..)
, SourcePosition (..)
, ParcomT, parseT
, Parcom, parse
, peek, next, atEnd
, try, handle, handleB
, notFollowedBy
, (<?>), (<|>), empty
, Stream, Token, Listish, Textish
, peekChar, nextChar
)
where
import qualified Text.Parcom.Stream as Stream
import Text.Parcom.Stream (Stream, Token, Listish, Textish)
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
(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)
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
Left e -> errorH e s s'
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')
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'))
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'))
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)
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)
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 }
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
peekChar :: (Monad m, Stream s t, Token t, Textish s) => ParcomT s t m Char
peekChar = do
str <- psStream `liftM` getState
let (charMay, _) = Stream.peekChar str
case charMay of
Just c -> return c
Nothing -> fail "Tokens do not form a valid character, or end of input reached"
nextChar :: (Monad m, Stream s t, Token t, Textish s) => ParcomT s t m Char
nextChar = do
str <- psStream `liftM` getState
let (charMay, numTokens) = Stream.peekChar str
case charMay of
Just c -> do
replicateM_ numTokens next
return c
Nothing -> fail "Tokens do not form a valid character, or end of input reached"
infixl 3 <?>
(<?>) :: (Monad m, Stream s t) => ParcomT s t m a -> String -> ParcomT s t m a
p <?> expected = p <|> fail ("Expected " ++ expected)