module Comark.ParserCombinators.Prim
( Position(..)
, Parser()
, runParser
, ParserState()
, ParseError(..)
, withConsumed
, consumedBy
, string
, (<?>)
, runParserWithUnconsumed
, getPosition
, setPosition
, satisfy
, peekChar
, peekLastChar
, replacing
, endOfInput
, takeWhile
, takeWhile1
, untilTheEnd
, skip
, skipWhile
, skipWhile1
, stringCaseless
, scan
, lookAhead
, notFollowedBy
) where
import Control.Applicative
import Control.Monad
import Data.String
import Data.Text (Text)
import qualified Data.Text as Text
import Prelude hiding (takeWhile)
data Position
= Position
{ line :: Int
, column :: Int
, point :: Int
} deriving (Ord, Eq)
instance Show Position where
show (Position ln cn pn) =
concat ["line ", show ln, " column ", show cn, " point ", show pn]
data ParseError
= ParseError
{ parseErrorPosition :: Position
, parseErrorReason :: String
} deriving (Show)
data ParserState
= ParserState
{ subject :: Text
, position :: Position
, lastChar :: Maybe Char
}
advance :: ParserState -> Text -> ParserState
advance = Text.foldl' go
where
go :: ParserState -> Char -> ParserState
go st c =
ParserState
{ subject = Text.drop 1 (subject st)
, position =
case c of
'\n' -> Position
{ line = line (position st) + 1
, column = 1
, point = point (position st) + 1
}
_ -> Position
{ line = line (position st)
, column = column (position st) + 1
, point = point (position st) + 1
}
, lastChar = Just c
}
newtype Parser a
= Parser
{ evalParser :: ParserState -> Either ParseError (ParserState, a) }
withConsumed :: Parser a -> Parser (a,Text)
withConsumed p = Parser $ \st ->
case (evalParser p) st of
Left err -> Left err
Right (st', res) ->
let consumedLength = point (position st') point (position st)
in Right (st', (res, Text.take consumedLength (subject st)))
consumedBy :: Parser a -> Parser Text
consumedBy = fmap snd . withConsumed
instance Functor Parser where
fmap f (Parser g) = Parser $ \st ->
case g st of
Right (st', x) -> Right (st', f x)
Left e -> Left e
instance Applicative Parser where
pure x = Parser $ \st -> Right (st, x)
(Parser f) <*> (Parser g) = Parser $ \st ->
case f st of
Left e -> Left e
Right (st', h) -> case g st' of
Right (st'', x) -> Right (st'', h x)
Left e -> Left e
instance Alternative Parser where
empty = Parser $ \st -> Left $ ParseError (position st) "(empty)"
(Parser f) <|> (Parser g) = Parser $ \st ->
case f st of
Right res -> Right res
Left (ParseError pos msg) ->
case g st of
Right res -> Right res
Left (ParseError pos' msg') -> Left $
case () of
_ | pos' > pos -> ParseError pos' msg'
| pos' < pos -> ParseError pos msg
| otherwise
-> ParseError pos (msg ++ " or " ++ msg')
instance Monad Parser where
return x = Parser $ \st -> Right (st, x)
fail e = Parser $ \st -> Left $ ParseError (position st) e
p >>= g = Parser $ \st ->
case evalParser p st of
Left e -> Left e
Right (st',x) -> evalParser (g x) st'
instance MonadPlus Parser where
mzero = Parser $ \st -> Left $ ParseError (position st) "(mzero)"
mplus p1 p2 = Parser $ \st ->
case evalParser p1 st of
Right res -> Right res
Left _ -> evalParser p2 st
instance (a ~ Text) => IsString (Parser a) where
fromString = string . Text.pack
string :: Text -> Parser Text
string s = Parser $ \st ->
if s `Text.isPrefixOf` (subject st)
then success (advance st s) s
else failure st "string"
failure :: ParserState -> String -> Either ParseError (ParserState, a)
failure st msg = Left $ ParseError (position st) msg
success :: ParserState -> a -> Either ParseError (ParserState, a)
success st x = Right (st, x)
(<?>) :: Parser a -> String -> Parser a
p <?> msg = Parser $ \st ->
let startpos = position st in
case evalParser p st of
Left (ParseError _ _) ->
Left $ ParseError startpos msg
Right r -> Right r
infixl 5 <?>
runParser :: Parser a -> Text -> Either ParseError a
runParser p t =
fmap snd $ evalParser p ParserState { subject = t
, position = Position 1 1 1
, lastChar = Nothing
}
runParserWithUnconsumed :: Parser a -> Text -> Either ParseError (a,Text)
runParserWithUnconsumed p t =
fmap (\(st,res) -> (res, subject st))
$ evalParser p ParserState { subject = t
, position = Position 1 1 1
, lastChar = Nothing
}
getState :: Parser ParserState
getState = Parser (\st -> success st st)
getPosition :: Parser Position
getPosition = position <$> getState
satisfy :: (Char -> Bool) -> Parser Char
satisfy f = Parser g
where g st = case Text.uncons (subject st) of
Just (c, _) | f c ->
success (advance st (Text.singleton c)) c
_ -> failure st "character meeting condition"
peekChar :: Parser (Maybe Char)
peekChar = maybeHead . subject <$> getState
where maybeHead = fmap fst . Text.uncons
peekLastChar :: Parser (Maybe Char)
peekLastChar = lastChar <$> getState
replacing :: Parser Text -> Parser ()
replacing p = do
s0 <- getState
t <- p
s1Subject <- subject <$> getState
Parser $ \_ -> success s0 { subject = Text.append t s1Subject } ()
endOfInput :: Parser ()
endOfInput = Parser $ \st ->
if Text.null (subject st)
then success st ()
else failure st "end of input"
setPosition :: Position -> Parser ()
setPosition pos = Parser $ \st -> success st{ position = pos } ()
takeWhile :: (Char -> Bool) -> Parser Text
takeWhile f = Parser $ \st ->
let t = Text.takeWhile f (subject st) in
success (advance st t) t
takeWhile1 :: (Char -> Bool) -> Parser Text
takeWhile1 f = Parser $ \st ->
case Text.takeWhile f (subject st) of
t | Text.null t -> failure st "characters satisfying condition"
| otherwise -> success (advance st t) t
untilTheEnd :: Parser Text
untilTheEnd = Parser $ \st ->
success (advance st (subject st)) (subject st)
skip :: (Char -> Bool) -> Parser ()
skip f = Parser $ \st ->
case Text.uncons (subject st) of
Just (c,_) | f c -> success (advance st (Text.singleton c)) ()
_ -> failure st "character satisfying condition"
skipWhile :: (Char -> Bool) -> Parser ()
skipWhile f = Parser $ \st ->
let t' = Text.takeWhile f (subject st) in
success (advance st t') ()
skipWhile1 :: (Char -> Bool) -> Parser ()
skipWhile1 f = Parser $ \st ->
case Text.takeWhile f (subject st) of
t' | Text.null t' -> failure st "characters satisfying condition"
| otherwise -> success (advance st t') ()
stringCaseless :: Text -> Parser Text
stringCaseless (Text.toCaseFold -> s) = Parser $ \st ->
if Text.toCaseFold s `Text.isPrefixOf` Text.toCaseFold (subject st)
then success (advance st s) s
else failure st "stringCaseless"
scan :: s -> (s -> Char -> Maybe s) -> Parser Text
scan s0 f = Parser $ go s0 []
where go s cs st =
case Text.uncons (subject st) of
Nothing -> finish st cs
Just (c, _) -> case f s c of
Just s' -> go s' (c:cs)
(advance st (Text.singleton c))
Nothing -> finish st cs
finish st cs =
success st (Text.pack (reverse cs))
lookAhead :: Parser a -> Parser a
lookAhead p = Parser $ \st ->
either
(const (failure st "lookAhead"))
(success st . snd)
(evalParser p st)
notFollowedBy :: Parser a -> Parser ()
notFollowedBy p = Parser $ \st ->
either
(const (success st ()))
(const (failure st "notFollowedBy"))
(evalParser p st)