module Control.Parser (
module SimpleH,
ParserT(..),Parser,ParserA(..),_ParserA,
Stream(..),emptyStream,
parserT,parser,runParser,runParserT,pureParser,eitherParser,
(<+>),(>*>),(<*<),
token,satisfy,
oneOf,noneOf,single,
several,
remaining,eoi,
readable,number,digit,letter,alNum,quotedString,space,spaces,eol,
many,many1,sepBy,sepBy1,
chainl,chainr
) where
import SimpleH
import qualified Data.ByteString.Char8 as BS
import Data.Char
newtype ParserT w s m a = ParserT (StateT s (ListT (WriterT w m)) a)
deriving (Unit,Functor,Applicative,Monoid,Semigroup,
Monad,MonadFix,MonadState s,MonadWriter w)
type Parser w c a = ParserT w c Id a
deriving instance (Monad m,Monoid w) => MonadError Void (ParserT w c m)
instance Monoid w => MonadTrans (ParserT w s) where
lift = ParserT . lift . lift . lift
generalize = parserT %%~ map (pure.yb _Id)
_ParserT :: Iso (ParserT w s m a) (ParserT x t n b) (StateT s (ListT (WriterT w m)) a) (StateT t (ListT (WriterT x n)) b)
_ParserT = iso ParserT (\(ParserT p) -> p)
parserT :: (Functor n,Functor m) => Iso (ParserT w s m a) (ParserT x t n b) (s -> m (w,[(s,a)])) (t -> n (x,[(t,b)]))
parserT = _mapping (_writerT._listT).stateT._ParserT
parser :: Iso (Parser w s a) (Parser x t b) (s -> (w,[(s,a)])) (t -> (x,[(t,b)]))
parser = _mapping _Id.parserT
runParser :: Parser Void s a -> s -> [(s,a)]
runParser = map snd . yb parser
runParserT :: Functor m => ParserT Void s m a -> s -> m [(s,a)]
runParserT = map2 snd . (^..parserT)
pureParser :: (Monoid w,Monad m) => (s -> [a]) -> ParserT w s m a
pureParser p = (\a -> pure (zero,[(a,b) | b <- p a]))^.parserT
eitherParser :: Monoid w => (s -> Either w a) :<->: Parser w s a
eitherParser = iso (\p s -> (,[])<|>pure.pure.(s,) $ p s)
(\p' s -> case p' s of
(w,[]) -> Left w
(_,((_,a):_)) -> Right a).parser
(<+>) :: Semigroup m => m -> m -> m
(<+>) = (+)
(>*>) :: (Monoid w, Monad m) => ParserT w a m b -> ParserT w b m c -> ParserT w a m c
(>*>) = (>>>)^..(_ParserA<.>_ParserA<.>_ParserA)
(<*<) :: (Monoid w, Monad m) => ParserT w b m c -> ParserT w a m b -> ParserT w a m c
(<*<) = flip (>*>)
newtype ParserA w m s a = ParserA (ParserT w s m a)
_ParserA :: Iso (ParserA w m s a) (ParserA w' m' s' a') (ParserT w s m a) (ParserT w' s' m' a')
_ParserA = iso ParserA (\(ParserA p) -> p)
parserA :: Iso (ParserA w m s a) (ParserA w' m' s' a') (StateA (ListT (WriterT w m)) s a) (StateA (ListT (WriterT w' m')) s' a')
parserA = from stateA._ParserT._ParserA
instance (Monoid w,Monad m) => Category (ParserA w m) where
id = ParserA get
(.) = (.)^.(parserA<.>parserA<.>parserA)
instance (Monoid w,Monad m) => Split (ParserA w m) where
(<#>) = (<#>)^.(parserA<.>parserA<.>parserA)
instance (Monoid w,Monad m) => Choice (ParserA w m) where
(<|>) = (<|>)^.(parserA<.>parserA<.>parserA)
instance (Monoid w,Monad m) => Arrow (ParserA w m) where
arr f = arr f^.parserA
remaining :: (Monad m,Monoid w) => ParserT w s m s
remaining = get
token :: (Monad m,Monoid w,Stream c s) => ParserT w s m c
token = get >>= \s -> case uncons s of
Nothing -> zero
Just (c,t) -> put t >> pure c
many :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]
many p = liftA2 (:) p (many p) <+> pure []
many1 :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]
many1 p = (:)<$>p<*>many p
satisfy :: (Monoid w, Monad m, Stream c s) => (c -> Bool) -> ParserT w s m c
satisfy p = token <*= guard . p
single :: (Eq c, Monoid w, Monad m, Stream c s) => c -> ParserT w s m ()
single = void . satisfy . (==)
several :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m ()
several l = traverse_ single l
option :: (Monoid w,Monad m) => a -> ParserT w s m a -> ParserT w s m a
option a p = p+pure a
eoi :: (Monad m,Monoid w,Stream c s) => ParserT w s m ()
eoi = remaining >>= guard.emptyStream
eol :: (Monad m,Monoid w,Stream Char s) => ParserT w s m ()
eol = single '\n'
sepBy1 ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a]
sepBy1 p sep = (:)<$>p<*>many (sep >> p)
sepBy ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a]
sepBy p sep = option [] (sepBy1 p sep)
oneOf :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m c
oneOf = satisfy . flip elem
noneOf :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m c
noneOf = satisfy . map not . flip elem
number :: (Monoid w,Monad m,Stream Char s,Num n) => ParserT w s m n
number = fromInteger.read <$> many1 digit
digit :: (Monoid w,Monad m,Stream Char s) => ParserT w s m Char
digit = satisfy isDigit
alNum :: (Monoid w,Monad m,Stream Char s) => ParserT w s m Char
alNum = satisfy isAlphaNum
letter :: (Monoid w,Monad m,Stream Char s) => ParserT w s m Char
letter = satisfy isAlpha
quotedString :: (Monoid w,Monad m,Stream Char s) => Char -> ParserT w 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 :: (Monoid w,Monad m,Stream Char s) => ParserT w s m Char
space = satisfy isSpace
spaces :: (Monoid w,Monad m,Stream Char s) => ParserT w s m String
spaces = many1 space
infixl 1 `sepBy`,`sepBy1`
infixr 0 <+>
chainr :: (Monoid w,Stream c s,Monad m) => ParserT w s m a -> ParserT w s m (b -> a -> a) -> ParserT w s m b -> ParserT w s m a
chainr expr op e = compose<$>many (op<**>e)<*>expr
chainl :: (Monoid w,Stream c s,Monad m) => ParserT w s m a -> ParserT w s m (a -> b -> a) -> ParserT w s m b -> ParserT w s m a
chainl expr op e = compose<$>many (flip<$>op<*>e)<**>expr
class Stream c s | s -> c where
uncons :: s -> Maybe (c,s)
cons :: c -> s -> s
instance Stream a [a] where
uncons [] = Nothing
uncons (x:xs) = Just (x,xs)
cons = (:)
instance Stream Char BS.ByteString where
uncons = BS.uncons
cons = BS.cons
emptyStream :: Stream c s => s -> Bool
emptyStream = maybe True (const False) . uncons
class Serializable t where
encode :: t -> BS.ByteString
decode :: Parser String BS.ByteString t
instance Serializable BS.ByteString where
encode = id ; decode = get
readable :: (Monoid w,Monad m,Read a) => ParserT w String m a
readable = map (pure.pure.map swap) (readsPrec 0)^.parserT