module Language.Parser (
module Definitive,
ParserT(..),Parser,ParserA(..),i'ParserA,
Stream(..),emptyStream,
parserT,parser,ioParser,
(<+>),(>*>),(<*<),cut,
token,satisfy,
oneOf,noneOf,single,
several,
remaining,eoi,
readable,number,digit,letter,alNum,quotedString,space,spaces,eol,
many,many1,sepBy,sepBy1,skipMany,skipMany1,
chainl,chainr,option
) where
import Definitive hiding (take)
import Data.Char
import Data.Containers.Sequence
newtype ParserT s m a = ParserT (StateT s (LogicT m) a)
deriving (Unit,Functor,Semigroup,Monoid,Applicative,
MonadFix,MonadState s)
instance (Monad m,Stream Char s) => IsString (ParserT s m a) where
fromString s = undefined <$ several s
instance Monad m => Monad (ParserT s m) where join = coerceJoin ParserT
type Parser c a = ParserT c Id a
instance MonadTrans (ParserT s) where
lift = ParserT . lift . lift
instance ConcreteMonad (ParserT s) where
generalize = parserT %%~ map (pure.yb i'Id)
i'ParserT :: Iso (ParserT s m a) (ParserT t n b) (StateT s (LogicT m) a) (StateT t (LogicT n) b)
i'ParserT = iso ParserT (\(ParserT p) -> p)
parserT :: (Monad n,Monad m) => Iso (ParserT s m a) (ParserT t n b) (s -> m [(s,a)]) (t -> n [(t,b)])
parserT = mapping listLogic.stateT.i'ParserT
parser :: Iso (Parser s a) (Parser t b) (s -> [(s,a)]) (t -> [(t,b)])
parser = mapping i'Id.parserT
ioParser :: Parser a b -> (a -> IO b)
ioParser p s = case (p^..parser) s of
[] -> error "Error in parsing"
(_,a):_ -> return a
(<+>) :: Semigroup m => m -> m -> m
(<+>) = (+)
(>*>) :: Monad m => ParserT a m b -> ParserT b m c -> ParserT a m c
(>*>) = (>>>)^..(i'ParserA<.>i'ParserA<.>i'ParserA)
(<*<) :: Monad m => ParserT b m c -> ParserT a m b -> ParserT a m c
(<*<) = flip (>*>)
cut :: Monad m => ParserT s m a -> ParserT s m a
cut = parserT %%~ map2 (take 1)
newtype ParserA m s a = ParserA (ParserT s m a)
i'ParserA :: Iso (ParserA m s a) (ParserA m' s' a') (ParserT s m a) (ParserT s' m' a')
i'ParserA = iso ParserA (\(ParserA p) -> p)
parserA :: Iso (ParserA m s a) (ParserA m' s' a') (StateA (LogicT m) s a) (StateA (LogicT m') s' a')
parserA = from stateA.i'ParserT.i'ParserA
instance Monad m => Deductive (ParserA m) where
(.) = (.)^.(parserA<.>parserA<.>parserA)
instance Monad m => Category (ParserA m) where
id = ParserA get
instance Monad m => Split (ParserA m) where
(<#>) = (<#>)^.(parserA<.>parserA<.>parserA)
instance Monad m => Choice (ParserA m) where
(<|>) = (<|>)^.(parserA<.>parserA<.>parserA)
instance Monad m => Arrow (ParserA m) where
arr f = arr f^.parserA
remaining :: Monad m => ParserT s m s
remaining = get
token :: (Monad m,Stream c s) => ParserT s m c
token = get >>= \s -> case uncons s of
Nothing -> zero
Just (c,t) -> c <$ put t
many :: Monad m => ParserT c m a -> ParserT c m [a]
many p = many1 p <+> pure []
many1 :: Monad m => ParserT c m a -> ParserT c m [a]
many1 p = (:)<$>p<*>many p
skipMany :: Monad m => ParserT c m a -> ParserT c m ()
skipMany p = skipMany1 p <+> pure ()
skipMany1 :: Monad m => ParserT c m a -> ParserT c m ()
skipMany1 p = p >> skipMany p
satisfy :: (Monad m, Stream c s) => (c -> Bool) -> ParserT s m c
satisfy p = token <*= guard . p
single :: (Eq c, Monad m, Stream c s) => c -> ParserT s m ()
single = void . satisfy . (==)
several :: (Eq c, Monad m, Foldable t, Stream c s) => t c -> ParserT s m ()
several l = traverse_ single l
option :: Monad m => a -> ParserT s m a -> ParserT s m a
option a p = p <+> pure a
eoi :: (Monad m,Stream c s) => ParserT s m ()
eoi = remaining >>= guard.emptyStream
eol :: (Monad m,Stream Char s) => ParserT s m ()
eol = single '\n'
sepBy1 ::Monad m => ParserT c m a -> ParserT c m b -> ParserT c m [a]
sepBy1 p sep = (:)<$>p<*>many (sep >> p)
sepBy ::Monad m => ParserT c m a -> ParserT c m b -> ParserT c m [a]
sepBy p sep = option [] (sepBy1 p sep)
oneOf :: (Eq c, Monad m, Foldable t, Stream c s) => t c -> ParserT s m c
oneOf = satisfy . flip elem
noneOf :: (Eq c, Monad m, Foldable t, Stream c s) => t c -> ParserT s m c
noneOf = satisfy . map not . flip elem
number :: (Monad m,Stream Char s,Num n) => ParserT s m n
number = fromInteger.read <$> many1 digit
digit :: (Monad m,Stream Char s) => ParserT s m Char
digit = satisfy isDigit
alNum :: (Monad m,Stream Char s) => ParserT s m Char
alNum = satisfy isAlphaNum
letter :: (Monad m,Stream Char s) => ParserT s m Char
letter = satisfy isAlpha
quotedString :: (Monad m,Stream Char s) => Char -> ParserT s m String
quotedString d = between (single d) (single d) (many ch)
where ch = single '\\' >> unquote<$>token
<+> noneOf (d:"\\")
unquote 'n' = '\n'
unquote 't' = '\t'
unquote c = c
space :: (Monad m,Stream Char s) => ParserT s m Char
space = satisfy isSpace
spaces :: (Monad m,Stream Char s) => ParserT s m String
spaces = many1 space
infixl 1 `sepBy`,`sepBy1`
infixr 0 <+>
chainr :: (Stream c s,Monad m) => ParserT s m a -> ParserT s m (b -> a -> a) -> ParserT s m b -> ParserT s m a
chainr expr op e = compose<$>many (op<**>e)<*>expr
chainl :: (Stream c s,Monad m) => ParserT s m a -> ParserT s m (a -> b -> a) -> ParserT s m b -> ParserT s m a
chainl expr op e = compose<$>many (flip<$>op<*>e)<**>expr
emptyStream :: Stream c s => s -> Bool
emptyStream = maybe True (const False) . uncons
readable :: (Monad m,Read a) => ParserT String m a
readable = generalize $ map2 swap (readsPrec 0)^.parser