module Hpp.Parser (Parser(..), parse,
awaitP, awaitJust, replace, droppingWhile, liftP,
onParserSource, precede, takingWhile,
zoomParse, zoomParseChunks) where
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
import Control.Monad.Trans.State.Strict
import Hpp.Streamer (Source, Streamer(..), yield, before, processPrefix,
nextOutput, flattenTil, StreamStep(..))
import Hpp.Types (HasError(..), HasHppState(..), Error(UserError))
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (MonadIO, liftIO)
type ParserR m r i = StateT (Source m i r) m
newtype Parser m i o = Parser { runParser :: forall r. ParserR m r i o }
parse :: Monad m => Parser m i o -> Source m i r -> m o
parse (Parser m) s = evalStateT m s
instance Functor m => Functor (Parser m i) where
fmap f (Parser p) = Parser (fmap f p)
instance Monad m => Applicative (Parser m i) where
pure x = Parser (pure x)
Parser f <*> Parser x = Parser (f <*> x)
instance Monad m => Monad (Parser m i) where
return = pure
Parser ma >>= fb = Parser $ ma >>= runParser . fb
instance MonadPlus m => Alternative (Parser m i) where
empty = Parser empty
Parser a <|> Parser b = Parser (a <|> b)
instance (Monad m, HasError m) => HasError (Parser m i) where
throwError = liftP . throwError
instance (Monad m, HasHppState m) => HasHppState (Parser m i) where
getState = liftP getState
setState = liftP . setState
instance MonadIO m => MonadIO (Parser m i) where
liftIO = liftP . liftIO
liftP :: Monad m => m o -> Parser m i o
liftP m = Parser (lift m)
onParserSource :: Monad m => Streamer m i i () -> Parser m i ()
onParserSource s = Parser (modify' (flip processPrefix s))
awaitP :: Monad m => Parser m i (Maybe i)
awaitP = Parser $ get >>= lift . nextOutput >>= \case
Left _ -> put empty >> return Nothing
Right !(!i, !src') -> put src' >> return (Just i)
awaitJust :: (Monad m, HasError m) => String -> Parser m i i
awaitJust s = awaitP >>= maybe (liftP $ throwError err) return
where err = UserError 0 ("awaitJust: " ++ s)
replace :: Monad m => i -> Parser m i ()
replace x = Parser $ modify' (before (yield x))
precede :: Monad m => Source m i r -> Parser m i ()
precede m = Parser (modify' (before m))
droppingWhile :: Monad m => (i -> Bool) -> Parser m i ()
droppingWhile p = go
where go = awaitP >>= \case
Nothing -> return ()
Just x -> if p x then go else replace x
takingWhile :: Monad m => (i -> Bool) -> Parser m i [i]
takingWhile p = go id
where go acc = awaitP >>= \case
Nothing -> return (acc [])
Just x
| p x -> go (acc . (x:))
| otherwise -> replace x >> return (acc [])
zoomParse :: Monad m
=> (forall r. Source m a r -> Source m b (Source m a r))
-> Parser m b o
-> Parser m a o
zoomParse f (Parser p) = Parser $ do
src <- get
(r, src') <- lift $ runStateT p (f src)
lift (runStream src') >>= \case
Await k _ -> lift (runStream (k undefined)) >>= \case
Done (Just src'') -> r <$ put src''
_ -> error "zoomParse blew it"
Done (Just src'') -> r <$ put src''
Done Nothing -> r <$ put empty
Yield _ _ -> error "zoomParse blew it by yielding"
zoomParseChunks :: Monad m => Parser m i r -> Parser m [i] r
zoomParseChunks = zoomParse flattenTil