{-# LANGUAGE DeriveFunctor, LambdaCase, TupleSections #-}
-- | Parsers over streaming input.
module Hpp.Parser (Parser, ParserT, evalParse, await, awaitJust, replace,
                   droppingWhile, precede, takingWhile, onElements,
                   onInputSegment, insertInputSegment, onIsomorphism) where
import Control.Arrow ((***))
import Control.Monad.Trans.State.Strict
import Hpp.Types (HasError(..), Error(UserError))
import Control.Monad.Trans.Class (lift)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (mapMaybe)

-- * Parsers

-- | A single pre-processor input is either an action or a value
data InputItem m a = Action (m ()) | Value a deriving a -> InputItem m b -> InputItem m a
(a -> b) -> InputItem m a -> InputItem m b
(forall a b. (a -> b) -> InputItem m a -> InputItem m b)
-> (forall a b. a -> InputItem m b -> InputItem m a)
-> Functor (InputItem m)
forall a b. a -> InputItem m b -> InputItem m a
forall a b. (a -> b) -> InputItem m a -> InputItem m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a b. a -> InputItem m b -> InputItem m a
forall (m :: * -> *) a b.
(a -> b) -> InputItem m a -> InputItem m b
<$ :: a -> InputItem m b -> InputItem m a
$c<$ :: forall (m :: * -> *) a b. a -> InputItem m b -> InputItem m a
fmap :: (a -> b) -> InputItem m a -> InputItem m b
$cfmap :: forall (m :: * -> *) a b.
(a -> b) -> InputItem m a -> InputItem m b
Functor

-- | Our input is a list of values each of which is either an action
-- or a value.
type Input m a = [InputItem m a]

-- | Functions for working with input sources.
data Source m src i =  Source { Source m src i -> src
srcSrc :: src
                              , Source m src i -> src -> m (Maybe (i, src))
_srcAwait :: src -> m (Maybe (i, src))
                              , Source m src i -> [i] -> src -> src
_srcPrecede :: [i] -> src -> src }

-- | A 'ParserT' is a bit of state that carries a source of input.
type ParserT m src i = StateT (Source m src i) m

-- | A 'Parser' is a bit of state that carries a source of input
-- consisting of a list of values which are either actions in an
-- underlying monad or sequences of inputs. Thus we have chunks of
-- input values with interspersed effects.
type Parser m i = ParserT m (Input m [i]) i

-- | Pop the head non-effect element from a list.
unconsM :: Applicative m => Input m a -> m (Maybe (a, Input m a))
unconsM :: Input m a -> m (Maybe (a, Input m a))
unconsM [] = Maybe (a, Input m a) -> m (Maybe (a, Input m a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (a, Input m a)
forall a. Maybe a
Nothing
unconsM (Action m ()
m : Input m a
ms) = m ()
m m () -> m (Maybe (a, Input m a)) -> m (Maybe (a, Input m a))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Input m a -> m (Maybe (a, Input m a))
forall (m :: * -> *) a.
Applicative m =>
Input m a -> m (Maybe (a, Input m a))
unconsM Input m a
ms
unconsM (Value a
x : Input m a
ms) = Maybe (a, Input m a) -> m (Maybe (a, Input m a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, Input m a) -> Maybe (a, Input m a)
forall a. a -> Maybe a
Just (a
x, Input m a
ms))

-- | Pop the first non-null, non-effect element from a list.
unconsMNonEmpty :: Monad m => Input m [a] -> m (Maybe (NonEmpty a, Input m [a]))
unconsMNonEmpty :: Input m [a] -> m (Maybe (NonEmpty a, Input m [a]))
unconsMNonEmpty Input m [a]
r = Input m [a] -> m (Maybe ([a], Input m [a]))
forall (m :: * -> *) a.
Applicative m =>
Input m a -> m (Maybe (a, Input m a))
unconsM Input m [a]
r m (Maybe ([a], Input m [a]))
-> (Maybe ([a], Input m [a])
    -> m (Maybe (NonEmpty a, Input m [a])))
-> m (Maybe (NonEmpty a, Input m [a]))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe ([a], Input m [a])
Nothing -> Maybe (NonEmpty a, Input m [a])
-> m (Maybe (NonEmpty a, Input m [a]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (NonEmpty a, Input m [a])
forall a. Maybe a
Nothing
  Just ([], Input m [a]
rst) -> Input m [a] -> m (Maybe (NonEmpty a, Input m [a]))
forall (m :: * -> *) a.
Monad m =>
Input m [a] -> m (Maybe (NonEmpty a, Input m [a]))
unconsMNonEmpty Input m [a]
rst
  Just (a
x:[a]
xs, Input m [a]
rst) -> Maybe (NonEmpty a, Input m [a])
-> m (Maybe (NonEmpty a, Input m [a]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((NonEmpty a, Input m [a]) -> Maybe (NonEmpty a, Input m [a])
forall a. a -> Maybe a
Just (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs, Input m [a]
rst))

unconsSource :: Monad m => Input m [i] -> Source m (Input m [i]) i
unconsSource :: Input m [i] -> Source m (Input m [i]) i
unconsSource Input m [i]
src = Input m [i]
-> (Input m [i] -> m (Maybe (i, Input m [i])))
-> ([i] -> Input m [i] -> Input m [i])
-> Source m (Input m [i]) i
forall (m :: * -> *) src i.
src
-> (src -> m (Maybe (i, src)))
-> ([i] -> src -> src)
-> Source m src i
Source Input m [i]
src Input m [i] -> m (Maybe (i, Input m [i]))
forall (m :: * -> *) a.
Monad m =>
Input m [a] -> m (Maybe (a, Input m [a]))
aw [i] -> Input m [i] -> Input m [i]
forall i (m :: * -> *). [i] -> Input m [i] -> Input m [i]
ropePrecede
  where aw :: Input m [a] -> m (Maybe (a, Input m [a]))
aw Input m [a]
r = Input m [a] -> m (Maybe (NonEmpty a, Input m [a]))
forall (m :: * -> *) a.
Monad m =>
Input m [a] -> m (Maybe (NonEmpty a, Input m [a]))
unconsMNonEmpty Input m [a]
r m (Maybe (NonEmpty a, Input m [a]))
-> (Maybe (NonEmpty a, Input m [a]) -> m (Maybe (a, Input m [a])))
-> m (Maybe (a, Input m [a]))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe (NonEmpty a, Input m [a])
Nothing -> Maybe (a, Input m [a]) -> m (Maybe (a, Input m [a]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, Input m [a])
forall a. Maybe a
Nothing
          Just (a
x :| [a]
xs, Input m [a]
r') -> Maybe (a, Input m [a]) -> m (Maybe (a, Input m [a]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Input m [a]) -> Maybe (a, Input m [a])
forall a. a -> Maybe a
Just (a
x, [a] -> InputItem m [a]
forall (m :: * -> *) a. a -> InputItem m a
Value [a]
xs InputItem m [a] -> Input m [a] -> Input m [a]
forall a. a -> [a] -> [a]
: Input m [a]
r'))

flattenSource :: Monad m => Source m (Input m [[i]]) [i] -> Source m (Input m [[i]]) i
flattenSource :: Source m (Input m [[i]]) [i] -> Source m (Input m [[i]]) i
flattenSource (Source Input m [[i]]
src0 Input m [[i]] -> m (Maybe ([i], Input m [[i]]))
aw [[i]] -> Input m [[i]] -> Input m [[i]]
pr) = Input m [[i]]
-> (Input m [[i]] -> m (Maybe (i, Input m [[i]])))
-> ([i] -> Input m [[i]] -> Input m [[i]])
-> Source m (Input m [[i]]) i
forall (m :: * -> *) src i.
src
-> (src -> m (Maybe (i, src)))
-> ([i] -> src -> src)
-> Source m src i
Source Input m [[i]]
src0 Input m [[i]] -> m (Maybe (i, Input m [[i]]))
aw' [i] -> Input m [[i]] -> Input m [[i]]
pr'
  where aw' :: Input m [[i]] -> m (Maybe (i, Input m [[i]]))
aw' Input m [[i]]
src = Input m [[i]] -> m (Maybe ([i], Input m [[i]]))
aw Input m [[i]]
src m (Maybe ([i], Input m [[i]]))
-> (Maybe ([i], Input m [[i]]) -> m (Maybe (i, Input m [[i]])))
-> m (Maybe (i, Input m [[i]]))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe ([i], Input m [[i]])
Nothing -> Maybe (i, Input m [[i]]) -> m (Maybe (i, Input m [[i]]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (i, Input m [[i]])
forall a. Maybe a
Nothing
          Just ([], Input m [[i]]
src') -> Input m [[i]] -> m (Maybe (i, Input m [[i]]))
aw' Input m [[i]]
src'
          Just (i
x:[i]
xs, Input m [[i]]
src') -> Maybe (i, Input m [[i]]) -> m (Maybe (i, Input m [[i]]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((i, Input m [[i]]) -> Maybe (i, Input m [[i]])
forall a. a -> Maybe a
Just (i
x, [i] -> Input m [[i]] -> Input m [[i]]
pr' [i]
xs Input m [[i]]
src'))
        pr' :: [i] -> Input m [[i]] -> Input m [[i]]
pr' [i]
xs Input m [[i]]
src = [[i]] -> Input m [[i]] -> Input m [[i]]
pr [[i]
xs] Input m [[i]]
src

await :: Monad m => ParserT m src i (Maybe i)
await :: ParserT m src i (Maybe i)
await = do Source src
src src -> m (Maybe (i, src))
aw [i] -> src -> src
pr <- StateT (Source m src i) m (Source m src i)
forall (m :: * -> *) s. Monad m => StateT s m s
get
           m (Maybe (i, src)) -> StateT (Source m src i) m (Maybe (i, src))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (src -> m (Maybe (i, src))
aw src
src) StateT (Source m src i) m (Maybe (i, src))
-> (Maybe (i, src) -> ParserT m src i (Maybe i))
-> ParserT m src i (Maybe i)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
             Maybe (i, src)
Nothing -> Maybe i -> ParserT m src i (Maybe i)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe i
forall a. Maybe a
Nothing
             Just (i
x, src
src') -> i -> Maybe i
forall a. a -> Maybe a
Just i
x Maybe i
-> StateT (Source m src i) m () -> ParserT m src i (Maybe i)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Source m src i -> StateT (Source m src i) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (src
-> (src -> m (Maybe (i, src)))
-> ([i] -> src -> src)
-> Source m src i
forall (m :: * -> *) src i.
src
-> (src -> m (Maybe (i, src)))
-> ([i] -> src -> src)
-> Source m src i
Source src
src' src -> m (Maybe (i, src))
aw [i] -> src -> src
pr)
{-# INLINE await #-}

-- | Push a value back into a parser's source.
replace :: (Monad m) => i -> ParserT m src i ()
replace :: i -> ParserT m src i ()
replace = [i] -> ParserT m src i ()
forall (m :: * -> *) i src. Monad m => [i] -> ParserT m src i ()
precede ([i] -> ParserT m src i ())
-> (i -> [i]) -> i -> ParserT m src i ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> [i]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

ropePrecede :: [i] -> Input m [i] -> Input m [i]
ropePrecede :: [i] -> Input m [i] -> Input m [i]
ropePrecede [i]
xs [] = [[i] -> InputItem m [i]
forall (m :: * -> *) a. a -> InputItem m a
Value [i]
xs]
ropePrecede [i]
xs ms :: Input m [i]
ms@(Action m ()
_ : Input m [i]
_) = [i] -> InputItem m [i]
forall (m :: * -> *) a. a -> InputItem m a
Value [i]
xs InputItem m [i] -> Input m [i] -> Input m [i]
forall a. a -> [a] -> [a]
: Input m [i]
ms
ropePrecede [i]
xs (Value [i]
ys : Input m [i]
ms) = [i] -> InputItem m [i]
forall (m :: * -> *) a. a -> InputItem m a
Value ([i]
xs[i] -> [i] -> [i]
forall a. [a] -> [a] -> [a]
++[i]
ys) InputItem m [i] -> Input m [i] -> Input m [i]
forall a. a -> [a] -> [a]
: Input m [i]
ms

-- | Push a stream of values back into a parser's source.
precede :: Monad m => [i] -> ParserT m src i ()
precede :: [i] -> ParserT m src i ()
precede [i]
xs = do Source src
src src -> m (Maybe (i, src))
aw [i] -> src -> src
pr <- StateT (Source m src i) m (Source m src i)
forall (m :: * -> *) s. Monad m => StateT s m s
get
                Source m src i -> ParserT m src i ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (src
-> (src -> m (Maybe (i, src)))
-> ([i] -> src -> src)
-> Source m src i
forall (m :: * -> *) src i.
src
-> (src -> m (Maybe (i, src)))
-> ([i] -> src -> src)
-> Source m src i
Source ([i] -> src -> src
pr [i]
xs src
src) src -> m (Maybe (i, src))
aw [i] -> src -> src
pr)
{-# INLINE precede #-}

-- | Evaluate a 'Parser' with a given input stream.
evalParse :: Monad m => Parser m i o -> [i] -> m o
evalParse :: Parser m i o -> [i] -> m o
evalParse Parser m i o
m [i]
xs = Parser m i o -> Source m (Input m [i]) i -> m o
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Parser m i o
m (Input m [i] -> Source m (Input m [i]) i
forall (m :: * -> *) i.
Monad m =>
Input m [i] -> Source m (Input m [i]) i
unconsSource [[i] -> InputItem m [i]
forall (m :: * -> *) a. a -> InputItem m a
Value [i]
xs])

-- * Operations on Parsers

-- | 'await' that throws an error with the given message if no more
-- input is available. This may be used to locate where in a
-- processing pipeline input was unexpectedly exhausted.
awaitJust :: (Monad m, HasError m) => String -> ParserT m src i i
awaitJust :: String -> ParserT m src i i
awaitJust String
s = ParserT m src i (Maybe i)
forall (m :: * -> *) src i. Monad m => ParserT m src i (Maybe i)
await ParserT m src i (Maybe i)
-> (Maybe i -> ParserT m src i i) -> ParserT m src i i
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParserT m src i i
-> (i -> ParserT m src i i) -> Maybe i -> ParserT m src i i
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (m i -> ParserT m src i i
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m i -> ParserT m src i i) -> m i -> ParserT m src i i
forall a b. (a -> b) -> a -> b
$ Error -> m i
forall (m :: * -> *) a. HasError m => Error -> m a
throwError Error
err) i -> ParserT m src i i
forall (m :: * -> *) a. Monad m => a -> m a
return
  where err :: Error
err = LineNum -> String -> Error
UserError LineNum
0 (String
"awaitJust: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
{-# INLINE awaitJust #-}

-- | Discard all values until one fails to satisfy a predicate. At
-- that point, the failing value is 'replace'd, and the
-- 'droppingWhile' stream stops.
droppingWhile :: (Monad m) => (i -> Bool) -> ParserT m src i ()
droppingWhile :: (i -> Bool) -> ParserT m src i ()
droppingWhile i -> Bool
p = ParserT m src i ()
forall src. StateT (Source m src i) m ()
go
  where go :: StateT (Source m src i) m ()
go = ParserT m src i (Maybe i)
forall (m :: * -> *) src i. Monad m => ParserT m src i (Maybe i)
await ParserT m src i (Maybe i)
-> (Maybe i -> StateT (Source m src i) m ())
-> StateT (Source m src i) m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
               Maybe i
Nothing -> () -> StateT (Source m src i) m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               Just i
x -> if i -> Bool
p i
x then StateT (Source m src i) m ()
go else i -> StateT (Source m src i) m ()
forall (m :: * -> *) i src. Monad m => i -> ParserT m src i ()
replace i
x
{-# INLINE droppingWhile #-}

-- | Echo all values until one fails to satisfy a predicate. At that
-- point, the failing value is 'replace'd, and the 'takingWhile'
-- stream stops.
takingWhile :: (Monad m) => (i -> Bool) -> ParserT m src i [i]
takingWhile :: (i -> Bool) -> ParserT m src i [i]
takingWhile i -> Bool
p = ([i] -> [i]) -> ParserT m src i [i]
forall (m :: * -> *) b src.
Monad m =>
([i] -> b) -> StateT (Source m src i) m b
go [i] -> [i]
forall a. a -> a
id
  where go :: ([i] -> b) -> StateT (Source m src i) m b
go [i] -> b
acc = ParserT m src i (Maybe i)
forall (m :: * -> *) src i. Monad m => ParserT m src i (Maybe i)
await ParserT m src i (Maybe i)
-> (Maybe i -> StateT (Source m src i) m b)
-> StateT (Source m src i) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                   Maybe i
Nothing -> b -> StateT (Source m src i) m b
forall (m :: * -> *) a. Monad m => a -> m a
return ([i] -> b
acc [])
                   Just i
x
                     | i -> Bool
p i
x -> ([i] -> b) -> StateT (Source m src i) m b
go ([i] -> b
acc ([i] -> b) -> ([i] -> [i]) -> [i] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i
xi -> [i] -> [i]
forall a. a -> [a] -> [a]
:))
                     | Bool
otherwise -> i -> ParserT m src i ()
forall (m :: * -> *) i src. Monad m => i -> ParserT m src i ()
replace i
x ParserT m src i ()
-> StateT (Source m src i) m b -> StateT (Source m src i) m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> StateT (Source m src i) m b
forall (m :: * -> *) a. Monad m => a -> m a
return ([i] -> b
acc [])
{-# INLINE takingWhile #-}

insertInputSegment :: Monad m => src -> m () -> ParserT m (Input m src) i ()
insertInputSegment :: src -> m () -> ParserT m (Input m src) i ()
insertInputSegment src
xs m ()
k =
  (Source m (Input m src) i -> Source m (Input m src) i)
-> ParserT m (Input m src) i ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (\Source m (Input m src) i
s -> Source m (Input m src) i
s { srcSrc :: Input m src
srcSrc = [src -> InputItem m src
forall (m :: * -> *) a. a -> InputItem m a
Value src
xs, m () -> InputItem m src
forall (m :: * -> *) a. m () -> InputItem m a
Action m ()
k] Input m src -> Input m src -> Input m src
forall a. [a] -> [a] -> [a]
++ Source m (Input m src) i -> Input m src
forall (m :: * -> *) src i. Source m src i -> src
srcSrc Source m (Input m src) i
s})

onInputSegment :: Monad m => (src -> src) -> ParserT m (Input m src) i ()
onInputSegment :: (src -> src) -> ParserT m (Input m src) i ()
onInputSegment src -> src
f =
  do Source Input m src
src Input m src -> m (Maybe (i, Input m src))
aw [i] -> Input m src -> Input m src
pr <- StateT (Source m (Input m src) i) m (Source m (Input m src) i)
forall (m :: * -> *) s. Monad m => StateT s m s
get
     case Input m src
src of
       [] -> () -> ParserT m (Input m src) i ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       (Value src
xs : Input m src
ys) -> Source m (Input m src) i -> ParserT m (Input m src) i ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Input m src
-> (Input m src -> m (Maybe (i, Input m src)))
-> ([i] -> Input m src -> Input m src)
-> Source m (Input m src) i
forall (m :: * -> *) src i.
src
-> (src -> m (Maybe (i, src)))
-> ([i] -> src -> src)
-> Source m src i
Source (src -> InputItem m src
forall (m :: * -> *) a. a -> InputItem m a
Value (src -> src
f src
xs) InputItem m src -> Input m src -> Input m src
forall a. a -> [a] -> [a]
: Input m src
ys) Input m src -> m (Maybe (i, Input m src))
aw [i] -> Input m src -> Input m src
pr)
       (Action m ()
m : Input m src
xs) -> m () -> ParserT m (Input m src) i ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
m ParserT m (Input m src) i ()
-> ParserT m (Input m src) i () -> ParserT m (Input m src) i ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Source m (Input m src) i -> ParserT m (Input m src) i ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Input m src
-> (Input m src -> m (Maybe (i, Input m src)))
-> ([i] -> Input m src -> Input m src)
-> Source m (Input m src) i
forall (m :: * -> *) src i.
src
-> (src -> m (Maybe (i, src)))
-> ([i] -> src -> src)
-> Source m src i
Source Input m src
xs Input m src -> m (Maybe (i, Input m src))
aw [i] -> Input m src -> Input m src
pr) ParserT m (Input m src) i ()
-> ParserT m (Input m src) i () -> ParserT m (Input m src) i ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (src -> src) -> ParserT m (Input m src) i ()
forall (m :: * -> *) src i.
Monad m =>
(src -> src) -> ParserT m (Input m src) i ()
onInputSegment src -> src
f
{-# INLINABLE onInputSegment #-}

-- * Parser Transformations

-- | A parser on lists of things can embed a parser on things. For
-- example, if we have a parser on lists of words, we can embed a
-- parser on individual words.
onElements :: Monad m => ParserT m (Input m [[i]]) i r -> Parser m [i] r
onElements :: ParserT m (Input m [[i]]) i r -> Parser m [i] r
onElements ParserT m (Input m [[i]]) i r
m = do s :: Source m (Input m [[i]]) [i]
s@(Source Input m [[i]]
_ Input m [[i]] -> m (Maybe ([i], Input m [[i]]))
aw [[i]] -> Input m [[i]] -> Input m [[i]]
pr) <- StateT
  (Source m (Input m [[i]]) [i]) m (Source m (Input m [[i]]) [i])
forall (m :: * -> *) s. Monad m => StateT s m s
get
                  (r
r, Source Input m [[i]]
src' Input m [[i]] -> m (Maybe (i, Input m [[i]]))
_ [i] -> Input m [[i]] -> Input m [[i]]
_) <- m (r, Source m (Input m [[i]]) i)
-> StateT
     (Source m (Input m [[i]]) [i]) m (r, Source m (Input m [[i]]) i)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParserT m (Input m [[i]]) i r
-> Source m (Input m [[i]]) i -> m (r, Source m (Input m [[i]]) i)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ParserT m (Input m [[i]]) i r
m (Source m (Input m [[i]]) [i] -> Source m (Input m [[i]]) i
forall (m :: * -> *) i.
Monad m =>
Source m (Input m [[i]]) [i] -> Source m (Input m [[i]]) i
flattenSource Source m (Input m [[i]]) [i]
s))
                  r
r r -> StateT (Source m (Input m [[i]]) [i]) m () -> Parser m [i] r
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Source m (Input m [[i]]) [i]
-> StateT (Source m (Input m [[i]]) [i]) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Input m [[i]]
-> (Input m [[i]] -> m (Maybe ([i], Input m [[i]])))
-> ([[i]] -> Input m [[i]] -> Input m [[i]])
-> Source m (Input m [[i]]) [i]
forall (m :: * -> *) src i.
src
-> (src -> m (Maybe (i, src)))
-> ([i] -> src -> src)
-> Source m src i
Source ((InputItem m [[i]] -> InputItem m [[i]])
-> Input m [[i]] -> Input m [[i]]
forall a. (a -> a) -> [a] -> [a]
onHead (([[i]] -> [[i]]) -> InputItem m [[i]] -> InputItem m [[i]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([i] -> Bool) -> [[i]] -> [[i]]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile [i] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)) Input m [[i]]
src') Input m [[i]] -> m (Maybe ([i], Input m [[i]]))
aw [[i]] -> Input m [[i]] -> Input m [[i]]
pr)
  where onHead :: (a -> a) -> [a] -> [a]
onHead a -> a
_ [] = []
        onHead a -> a
f (a
x:[a]
xs) = a -> a
f a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
{-# INLINE onElements #-}

-- | Given a function with type @a -> b@, and a partial inverse, @b ->
-- Maybe a@, we can embed a parser on values of type @b@ in a parser
-- on values of type @a@.
onIsomorphism :: Monad m
              => (a -> b)
              -> (b -> Maybe a)
              -> ParserT m ([b],src) b r
              -> ParserT m src a r
onIsomorphism :: (a -> b)
-> (b -> Maybe a) -> ParserT m ([b], src) b r -> ParserT m src a r
onIsomorphism a -> b
fwd b -> Maybe a
bwd ParserT m ([b], src) b r
m =
  do Source src
src src -> m (Maybe (a, src))
aw [a] -> src -> src
pr <- StateT (Source m src a) m (Source m src a)
forall (m :: * -> *) s. Monad m => StateT s m s
get
     let aw' :: ([b], src) -> m (Maybe (b, ([b], src)))
aw' ([], src
src') = (Maybe (a, src) -> Maybe (b, ([b], src)))
-> m (Maybe (a, src)) -> m (Maybe (b, ([b], src)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, src) -> (b, ([b], src)))
-> Maybe (a, src) -> Maybe (b, ([b], src))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
fwd (a -> b) -> (src -> ([b], src)) -> (a, src) -> (b, ([b], src))
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ([],))) (src -> m (Maybe (a, src))
aw src
src')
         aw' ((b
b:[b]
bs), src
src') = Maybe (b, ([b], src)) -> m (Maybe (b, ([b], src)))
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, ([b], src)) -> Maybe (b, ([b], src))
forall a. a -> Maybe a
Just (b
b, ([b]
bs,src
src')))
         pr' :: [a] -> ([a], b) -> ([a], b)
pr' [a]
xs ([a]
bs, b
src') = ([a]
xs[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
bs, b
src')
     (r
r, Source ([b]
bs, src
src') ([b], src) -> m (Maybe (b, ([b], src)))
_ [b] -> ([b], src) -> ([b], src)
_) <- m (r, Source m ([b], src) b)
-> StateT (Source m src a) m (r, Source m ([b], src) b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParserT m ([b], src) b r
-> Source m ([b], src) b -> m (r, Source m ([b], src) b)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ParserT m ([b], src) b r
m (([b], src)
-> (([b], src) -> m (Maybe (b, ([b], src))))
-> ([b] -> ([b], src) -> ([b], src))
-> Source m ([b], src) b
forall (m :: * -> *) src i.
src
-> (src -> m (Maybe (i, src)))
-> ([i] -> src -> src)
-> Source m src i
Source ([],src
src) ([b], src) -> m (Maybe (b, ([b], src)))
aw' [b] -> ([b], src) -> ([b], src)
forall a b. [a] -> ([a], b) -> ([a], b)
pr'))
     r
r r -> StateT (Source m src a) m () -> ParserT m src a r
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Source m src a -> StateT (Source m src a) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (src
-> (src -> m (Maybe (a, src)))
-> ([a] -> src -> src)
-> Source m src a
forall (m :: * -> *) src i.
src
-> (src -> m (Maybe (i, src)))
-> ([i] -> src -> src)
-> Source m src i
Source ([a] -> src -> src
pr ((b -> Maybe a) -> [b] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe b -> Maybe a
bwd [b]
bs) src
src') src -> m (Maybe (a, src))
aw [a] -> src -> src
pr)
{-# INLINE onIsomorphism #-}