{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.Types.SourceT where
import Control.Monad.Except
(ExceptT (..), runExceptT, throwError)
import Control.Monad.Morph
(MFunctor (..))
import Control.Monad.Trans.Class
(MonadTrans (..))
import qualified Data.Attoparsec.ByteString as A
import qualified Data.ByteString as BS
import Data.Functor.Classes
(Show1 (..), showsBinaryWith, showsPrec1, showsUnaryWith)
import Data.Functor.Identity
(Identity (..))
import Prelude ()
import Prelude.Compat hiding
(readFile)
import System.IO
(Handle, IOMode (..), withFile)
import qualified Test.QuickCheck as QC
newtype SourceT m a = SourceT
{ SourceT m a -> forall b. (StepT m a -> m b) -> m b
unSourceT :: forall b. (StepT m a -> m b) -> m b
}
mapStepT :: (StepT m a -> StepT m b) -> SourceT m a -> SourceT m b
mapStepT :: (StepT m a -> StepT m b) -> SourceT m a -> SourceT m b
mapStepT f :: StepT m a -> StepT m b
f (SourceT m :: forall b. (StepT m a -> m b) -> m b
m) = (forall b. (StepT m b -> m b) -> m b) -> SourceT m b
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
SourceT ((forall b. (StepT m b -> m b) -> m b) -> SourceT m b)
-> (forall b. (StepT m b -> m b) -> m b) -> SourceT m b
forall a b. (a -> b) -> a -> b
$ \k :: StepT m b -> m b
k -> (StepT m a -> m b) -> m b
forall b. (StepT m a -> m b) -> m b
m (StepT m b -> m b
k (StepT m b -> m b) -> (StepT m a -> StepT m b) -> StepT m a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StepT m a -> StepT m b
f)
{-# INLINE mapStepT #-}
data StepT m a
= Stop
| Error String
| Skip (StepT m a)
| Yield a (StepT m a)
| Effect (m (StepT m a))
deriving a -> StepT m b -> StepT m a
(a -> b) -> StepT m a -> StepT m b
(forall a b. (a -> b) -> StepT m a -> StepT m b)
-> (forall a b. a -> StepT m b -> StepT m a) -> Functor (StepT m)
forall a b. a -> StepT m b -> StepT m a
forall a b. (a -> b) -> StepT m a -> StepT m b
forall (m :: * -> *) a b. Functor m => a -> StepT m b -> StepT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> StepT m a -> StepT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> StepT m b -> StepT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> StepT m b -> StepT m a
fmap :: (a -> b) -> StepT m a -> StepT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> StepT m a -> StepT m b
Functor
fromStepT :: StepT m a -> SourceT m a
fromStepT :: StepT m a -> SourceT m a
fromStepT s :: StepT m a
s = (forall b. (StepT m a -> m b) -> m b) -> SourceT m a
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
SourceT ((StepT m a -> m b) -> StepT m a -> m b
forall a b. (a -> b) -> a -> b
$ StepT m a
s)
instance Functor m => Functor (SourceT m) where
fmap :: (a -> b) -> SourceT m a -> SourceT m b
fmap f :: a -> b
f = (StepT m a -> StepT m b) -> SourceT m a -> SourceT m b
forall (m :: * -> *) a b.
(StepT m a -> StepT m b) -> SourceT m a -> SourceT m b
mapStepT ((a -> b) -> StepT m a -> StepT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)
instance Identity ~ m => Foldable (SourceT m) where
foldr :: (a -> b -> b) -> b -> SourceT m a -> b
foldr f :: a -> b -> b
f z :: b
z (SourceT m :: forall b. (StepT m a -> m b) -> m b
m) = (a -> b -> b) -> b -> StepT m a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
f b
z (Identity (StepT m a) -> StepT m a
forall a. Identity a -> a
runIdentity ((StepT m a -> m (StepT m a)) -> m (StepT m a)
forall b. (StepT m a -> m b) -> m b
m StepT m a -> m (StepT m a)
forall a. a -> Identity a
Identity))
instance (Applicative m, Show1 m) => Show1 (SourceT m) where
liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> SourceT m a -> ShowS
liftShowsPrec sp :: Int -> a -> ShowS
sp sl :: [a] -> ShowS
sl d :: Int
d (SourceT m :: forall b. (StepT m a -> m b) -> m b
m) = (Int -> StepT m a -> ShowS) -> String -> Int -> StepT m a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith
((Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> StepT m a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl)
"fromStepT" Int
d (m (StepT m a) -> StepT m a
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
Effect ((StepT m a -> m (StepT m a)) -> m (StepT m a)
forall b. (StepT m a -> m b) -> m b
m StepT m a -> m (StepT m a)
forall (m :: * -> *) a. Applicative m => StepT m a -> m (StepT m a)
pure'))
where
pure' :: StepT m a -> m (StepT m a)
pure' (Effect s :: m (StepT m a)
s) = m (StepT m a)
s
pure' s :: StepT m a
s = StepT m a -> m (StepT m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure StepT m a
s
instance (Applicative m, Show1 m, Show a) => Show (SourceT m a) where
showsPrec :: Int -> SourceT m a -> ShowS
showsPrec = Int -> SourceT m a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1
instance MFunctor SourceT where
hoist :: (forall a. m a -> n a) -> SourceT m b -> SourceT n b
hoist f :: forall a. m a -> n a
f (SourceT m :: forall b. (StepT m b -> m b) -> m b
m) = (forall b. (StepT n b -> n b) -> n b) -> SourceT n b
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
SourceT ((forall b. (StepT n b -> n b) -> n b) -> SourceT n b)
-> (forall b. (StepT n b -> n b) -> n b) -> SourceT n b
forall a b. (a -> b) -> a -> b
$ \k :: StepT n b -> n b
k -> StepT n b -> n b
k (StepT n b -> n b) -> StepT n b -> n b
forall a b. (a -> b) -> a -> b
$
n (StepT n b) -> StepT n b
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
Effect (n (StepT n b) -> StepT n b) -> n (StepT n b) -> StepT n b
forall a b. (a -> b) -> a -> b
$ m (StepT n b) -> n (StepT n b)
forall a. m a -> n a
f (m (StepT n b) -> n (StepT n b)) -> m (StepT n b) -> n (StepT n b)
forall a b. (a -> b) -> a -> b
$ (StepT m b -> StepT n b) -> m (StepT m b) -> m (StepT n b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. m a -> n a) -> StepT m b -> StepT n b
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
(b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. m a -> n a
f) (m (StepT m b) -> m (StepT n b)) -> m (StepT m b) -> m (StepT n b)
forall a b. (a -> b) -> a -> b
$ (StepT m b -> m (StepT m b)) -> m (StepT m b)
forall b. (StepT m b -> m b) -> m b
m StepT m b -> m (StepT m b)
forall (m :: * -> *) a. Monad m => a -> m a
return
instance Functor m => Semigroup (SourceT m a) where
SourceT withL :: forall b. (StepT m a -> m b) -> m b
withL <> :: SourceT m a -> SourceT m a -> SourceT m a
<> SourceT withR :: forall b. (StepT m a -> m b) -> m b
withR = (forall b. (StepT m a -> m b) -> m b) -> SourceT m a
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
SourceT ((forall b. (StepT m a -> m b) -> m b) -> SourceT m a)
-> (forall b. (StepT m a -> m b) -> m b) -> SourceT m a
forall a b. (a -> b) -> a -> b
$ \ret :: StepT m a -> m b
ret ->
(StepT m a -> m b) -> m b
forall b. (StepT m a -> m b) -> m b
withL ((StepT m a -> m b) -> m b) -> (StepT m a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \l :: StepT m a
l ->
(StepT m a -> m b) -> m b
forall b. (StepT m a -> m b) -> m b
withR ((StepT m a -> m b) -> m b) -> (StepT m a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \r :: StepT m a
r ->
StepT m a -> m b
ret (StepT m a -> m b) -> StepT m a -> m b
forall a b. (a -> b) -> a -> b
$ StepT m a
l StepT m a -> StepT m a -> StepT m a
forall a. Semigroup a => a -> a -> a
<> StepT m a
r
instance Functor m => Monoid (SourceT m a) where
mempty :: SourceT m a
mempty = StepT m a -> SourceT m a
forall (m :: * -> *) a. StepT m a -> SourceT m a
fromStepT StepT m a
forall a. Monoid a => a
mempty
mappend :: SourceT m a -> SourceT m a -> SourceT m a
mappend = SourceT m a -> SourceT m a -> SourceT m a
forall a. Semigroup a => a -> a -> a
(<>)
instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (SourceT m a) where
arbitrary :: Gen (SourceT m a)
arbitrary = StepT m a -> SourceT m a
forall (m :: * -> *) a. StepT m a -> SourceT m a
fromStepT (StepT m a -> SourceT m a) -> Gen (StepT m a) -> Gen (SourceT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (StepT m a)
forall a. Arbitrary a => Gen a
QC.arbitrary
instance Identity ~ m => Foldable (StepT m) where
foldr :: (a -> b -> b) -> b -> StepT m a -> b
foldr f :: a -> b -> b
f z :: b
z = StepT m a -> b
StepT Identity a -> b
go where
go :: StepT Identity a -> b
go Stop = b
z
go (Error _) = b
z
go (Skip s :: StepT Identity a
s) = StepT Identity a -> b
go StepT Identity a
s
go (Yield a :: a
a s :: StepT Identity a
s) = a -> b -> b
f a
a (StepT Identity a -> b
go StepT Identity a
s)
go (Effect (Identity s :: StepT Identity a
s)) = StepT Identity a -> b
go StepT Identity a
s
instance (Applicative m, Show1 m) => Show1 (StepT m) where
liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> StepT m a -> ShowS
liftShowsPrec sp :: Int -> a -> ShowS
sp sl :: [a] -> ShowS
sl = Int -> StepT m a -> ShowS
go where
go :: Int -> StepT m a -> ShowS
go _ Stop = String -> ShowS
showString "Stop"
go d :: Int
d (Skip s :: StepT m a
s) = (Int -> StepT m a -> ShowS) -> String -> Int -> StepT m a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith
Int -> StepT m a -> ShowS
go
"Skip" Int
d StepT m a
s
go d :: Int
d (Error err :: String
err) = (Int -> String -> ShowS) -> String -> Int -> String -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith
Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec
"Error" Int
d String
err
go d :: Int
d (Effect ms :: m (StepT m a)
ms) = (Int -> m (StepT m a) -> ShowS)
-> String -> Int -> m (StepT m a) -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith
((Int -> StepT m a -> ShowS)
-> ([StepT m a] -> ShowS) -> Int -> m (StepT m a) -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> StepT m a -> ShowS
go [StepT m a] -> ShowS
goList)
"Effect" Int
d m (StepT m a)
ms
go d :: Int
d (Yield x :: a
x s :: StepT m a
s) = (Int -> a -> ShowS)
-> (Int -> StepT m a -> ShowS)
-> String
-> Int
-> a
-> StepT m a
-> ShowS
forall a b.
(Int -> a -> ShowS)
-> (Int -> b -> ShowS) -> String -> Int -> a -> b -> ShowS
showsBinaryWith
Int -> a -> ShowS
sp Int -> StepT m a -> ShowS
go
"Yield" Int
d a
x StepT m a
s
goList :: [StepT m a] -> ShowS
goList = (Int -> a -> ShowS) -> ([a] -> ShowS) -> [StepT m a] -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl
instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where
showsPrec :: Int -> StepT m a -> ShowS
showsPrec = Int -> StepT m a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1
instance MonadTrans StepT where
lift :: m a -> StepT m a
lift = m (StepT m a) -> StepT m a
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
Effect (m (StepT m a) -> StepT m a)
-> (m a -> m (StepT m a)) -> m a -> StepT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> StepT m a) -> m a -> m (StepT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> StepT m a -> StepT m a
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
`Yield` StepT m a
forall (m :: * -> *) a. StepT m a
Stop)
instance MFunctor StepT where
hoist :: (forall a. m a -> n a) -> StepT m b -> StepT n b
hoist f :: forall a. m a -> n a
f = StepT m b -> StepT n b
go where
go :: StepT m b -> StepT n b
go Stop = StepT n b
forall (m :: * -> *) a. StepT m a
Stop
go (Error err :: String
err) = String -> StepT n b
forall (m :: * -> *) a. String -> StepT m a
Error String
err
go (Skip s :: StepT m b
s) = StepT n b -> StepT n b
forall (m :: * -> *) a. StepT m a -> StepT m a
Skip (StepT m b -> StepT n b
go StepT m b
s)
go (Yield x :: b
x s :: StepT m b
s) = b -> StepT n b -> StepT n b
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield b
x (StepT m b -> StepT n b
go StepT m b
s)
go (Effect ms :: m (StepT m b)
ms) = n (StepT n b) -> StepT n b
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
Effect (m (StepT n b) -> n (StepT n b)
forall a. m a -> n a
f ((StepT m b -> StepT n b) -> m (StepT m b) -> m (StepT n b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StepT m b -> StepT n b
go m (StepT m b)
ms))
instance Functor m => Semigroup (StepT m a) where
Stop <> :: StepT m a -> StepT m a -> StepT m a
<> r :: StepT m a
r = StepT m a
r
Error err :: String
err <> _ = String -> StepT m a
forall (m :: * -> *) a. String -> StepT m a
Error String
err
Skip s :: StepT m a
s <> r :: StepT m a
r = StepT m a -> StepT m a
forall (m :: * -> *) a. StepT m a -> StepT m a
Skip (StepT m a
s StepT m a -> StepT m a -> StepT m a
forall a. Semigroup a => a -> a -> a
<> StepT m a
r)
Yield x :: a
x s :: StepT m a
s <> r :: StepT m a
r = a -> StepT m a -> StepT m a
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield a
x (StepT m a
s StepT m a -> StepT m a -> StepT m a
forall a. Semigroup a => a -> a -> a
<> StepT m a
r)
Effect ms :: m (StepT m a)
ms <> r :: StepT m a
r = m (StepT m a) -> StepT m a
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
Effect ((StepT m a -> StepT m a -> StepT m a
forall a. Semigroup a => a -> a -> a
<> StepT m a
r) (StepT m a -> StepT m a) -> m (StepT m a) -> m (StepT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (StepT m a)
ms)
instance Functor m => Monoid (StepT m a) where
mempty :: StepT m a
mempty = StepT m a
forall (m :: * -> *) a. StepT m a
Stop
mappend :: StepT m a -> StepT m a -> StepT m a
mappend = StepT m a -> StepT m a -> StepT m a
forall a. Semigroup a => a -> a -> a
(<>)
instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (StepT m a) where
arbitrary :: Gen (StepT m a)
arbitrary = (Int -> Gen (StepT m a)) -> Gen (StepT m a)
forall a. (Int -> Gen a) -> Gen a
QC.sized Int -> Gen (StepT m a)
forall a (m :: * -> *) a.
(Num a, Ord a, Monad m, Arbitrary a) =>
a -> Gen (StepT m a)
arb where
arb :: a -> Gen (StepT m a)
arb n :: a
n | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = StepT m a -> Gen (StepT m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure StepT m a
forall (m :: * -> *) a. StepT m a
Stop
| Bool
otherwise = [(Int, Gen (StepT m a))] -> Gen (StepT m a)
forall a. [(Int, Gen a)] -> Gen a
QC.frequency
[ (1, StepT m a -> Gen (StepT m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure StepT m a
forall (m :: * -> *) a. StepT m a
Stop)
, (1, StepT m a -> StepT m a
forall (m :: * -> *) a. StepT m a -> StepT m a
Skip (StepT m a -> StepT m a) -> Gen (StepT m a) -> Gen (StepT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (StepT m a)
arb')
, (1, m (StepT m a) -> StepT m a
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
Effect (m (StepT m a) -> StepT m a)
-> (StepT m a -> m (StepT m a)) -> StepT m a -> StepT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StepT m a -> m (StepT m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (StepT m a -> StepT m a) -> Gen (StepT m a) -> Gen (StepT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (StepT m a)
arb')
, (8, a -> StepT m a -> StepT m a
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield (a -> StepT m a -> StepT m a)
-> Gen a -> Gen (StepT m a -> StepT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
QC.arbitrary Gen (StepT m a -> StepT m a) -> Gen (StepT m a) -> Gen (StepT m a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (StepT m a)
arb')
]
where
arb' :: Gen (StepT m a)
arb' = a -> Gen (StepT m a)
arb (a
n a -> a -> a
forall a. Num a => a -> a -> a
- 1)
shrink :: StepT m a -> [StepT m a]
shrink Stop = []
shrink (Error _) = [StepT m a
forall (m :: * -> *) a. StepT m a
Stop]
shrink (Skip s :: StepT m a
s) = [StepT m a
s]
shrink (Effect _) = []
shrink (Yield x :: a
x s :: StepT m a
s) =
[ a -> StepT m a -> StepT m a
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield a
x' StepT m a
s | a
x' <- a -> [a]
forall a. Arbitrary a => a -> [a]
QC.shrink a
x ] [StepT m a] -> [StepT m a] -> [StepT m a]
forall a. [a] -> [a] -> [a]
++
[ a -> StepT m a -> StepT m a
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield a
x StepT m a
s' | StepT m a
s' <- StepT m a -> [StepT m a]
forall a. Arbitrary a => a -> [a]
QC.shrink StepT m a
s ]
source :: [a] -> SourceT m a
source :: [a] -> SourceT m a
source = StepT m a -> SourceT m a
forall (m :: * -> *) a. StepT m a -> SourceT m a
fromStepT (StepT m a -> SourceT m a)
-> ([a] -> StepT m a) -> [a] -> SourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> StepT m a -> StepT m a) -> StepT m a -> [a] -> StepT m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> StepT m a -> StepT m a
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield StepT m a
forall (m :: * -> *) a. StepT m a
Stop
runSourceT :: Monad m => SourceT m a -> ExceptT String m [a]
runSourceT :: SourceT m a -> ExceptT String m [a]
runSourceT (SourceT m :: forall b. (StepT m a -> m b) -> m b
m) = m (Either String [a]) -> ExceptT String m [a]
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((StepT m a -> m (Either String [a])) -> m (Either String [a])
forall b. (StepT m a -> m b) -> m b
m (ExceptT String m [a] -> m (Either String [a])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String m [a] -> m (Either String [a]))
-> (StepT m a -> ExceptT String m [a])
-> StepT m a
-> m (Either String [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StepT m a -> ExceptT String m [a]
forall (m :: * -> *) a.
Monad m =>
StepT m a -> ExceptT String m [a]
runStepT))
runStepT :: Monad m => StepT m a -> ExceptT String m [a]
runStepT :: StepT m a -> ExceptT String m [a]
runStepT Stop = [a] -> ExceptT String m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
runStepT (Error err :: String
err) = String -> ExceptT String m [a]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
err
runStepT (Skip s :: StepT m a
s) = StepT m a -> ExceptT String m [a]
forall (m :: * -> *) a.
Monad m =>
StepT m a -> ExceptT String m [a]
runStepT StepT m a
s
runStepT (Yield x :: a
x s :: StepT m a
s) = ([a] -> [a]) -> ExceptT String m [a] -> ExceptT String m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (StepT m a -> ExceptT String m [a]
forall (m :: * -> *) a.
Monad m =>
StepT m a -> ExceptT String m [a]
runStepT StepT m a
s)
runStepT (Effect ms :: m (StepT m a)
ms) = m (StepT m a) -> ExceptT String m (StepT m a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (StepT m a)
ms ExceptT String m (StepT m a)
-> (StepT m a -> ExceptT String m [a]) -> ExceptT String m [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StepT m a -> ExceptT String m [a]
forall (m :: * -> *) a.
Monad m =>
StepT m a -> ExceptT String m [a]
runStepT
mapMaybe :: Functor m => (a -> Maybe b) -> SourceT m a -> SourceT m b
mapMaybe :: (a -> Maybe b) -> SourceT m a -> SourceT m b
mapMaybe p :: a -> Maybe b
p (SourceT m :: forall b. (StepT m a -> m b) -> m b
m) = (forall b. (StepT m b -> m b) -> m b) -> SourceT m b
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
SourceT ((forall b. (StepT m b -> m b) -> m b) -> SourceT m b)
-> (forall b. (StepT m b -> m b) -> m b) -> SourceT m b
forall a b. (a -> b) -> a -> b
$ \k :: StepT m b -> m b
k -> (StepT m a -> m b) -> m b
forall b. (StepT m a -> m b) -> m b
m (StepT m b -> m b
k (StepT m b -> m b) -> (StepT m a -> StepT m b) -> StepT m a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> StepT m a -> StepT m b
forall (m :: * -> *) a b.
Functor m =>
(a -> Maybe b) -> StepT m a -> StepT m b
mapMaybeStep a -> Maybe b
p)
mapMaybeStep :: Functor m => (a -> Maybe b) -> StepT m a -> StepT m b
mapMaybeStep :: (a -> Maybe b) -> StepT m a -> StepT m b
mapMaybeStep p :: a -> Maybe b
p = StepT m a -> StepT m b
go where
go :: StepT m a -> StepT m b
go Stop = StepT m b
forall (m :: * -> *) a. StepT m a
Stop
go (Error err :: String
err) = String -> StepT m b
forall (m :: * -> *) a. String -> StepT m a
Error String
err
go (Skip s :: StepT m a
s) = StepT m b -> StepT m b
forall (m :: * -> *) a. StepT m a -> StepT m a
Skip (StepT m a -> StepT m b
go StepT m a
s)
go (Effect ms :: m (StepT m a)
ms) = m (StepT m b) -> StepT m b
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
Effect ((StepT m a -> StepT m b) -> m (StepT m a) -> m (StepT m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StepT m a -> StepT m b
go m (StepT m a)
ms)
go (Yield x :: a
x s :: StepT m a
s) = case a -> Maybe b
p a
x of
Nothing -> StepT m b -> StepT m b
forall (m :: * -> *) a. StepT m a -> StepT m a
Skip (StepT m a -> StepT m b
go StepT m a
s)
Just y :: b
y -> b -> StepT m b -> StepT m b
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield b
y (StepT m a -> StepT m b
go StepT m a
s)
foreach
:: Monad m
=> (String -> m ())
-> (a -> m ())
-> SourceT m a
-> m ()
foreach :: (String -> m ()) -> (a -> m ()) -> SourceT m a -> m ()
foreach f :: String -> m ()
f g :: a -> m ()
g src :: SourceT m a
src = SourceT m a -> (StepT m a -> m ()) -> m ()
forall (m :: * -> *) a.
SourceT m a -> forall b. (StepT m a -> m b) -> m b
unSourceT SourceT m a
src ((String -> m ()) -> (a -> m ()) -> StepT m a -> m ()
forall (m :: * -> *) a.
Monad m =>
(String -> m ()) -> (a -> m ()) -> StepT m a -> m ()
foreachStep String -> m ()
f a -> m ()
g)
foreachStep
:: Monad m
=> (String -> m ())
-> (a -> m ())
-> StepT m a
-> m ()
foreachStep :: (String -> m ()) -> (a -> m ()) -> StepT m a -> m ()
foreachStep f :: String -> m ()
f g :: a -> m ()
g = StepT m a -> m ()
go where
go :: StepT m a -> m ()
go Stop = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go (Skip s :: StepT m a
s) = StepT m a -> m ()
go StepT m a
s
go (Yield x :: a
x s :: StepT m a
s) = a -> m ()
g a
x m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StepT m a -> m ()
go StepT m a
s
go (Error err :: String
err) = String -> m ()
f String
err
go (Effect ms :: m (StepT m a)
ms) = m (StepT m a)
ms m (StepT m a) -> (StepT m a -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StepT m a -> m ()
go
fromAction :: Functor m => (a -> Bool) -> m a -> SourceT m a
fromAction :: (a -> Bool) -> m a -> SourceT m a
fromAction stop :: a -> Bool
stop action :: m a
action = (forall b. (StepT m a -> m b) -> m b) -> SourceT m a
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
SourceT ((StepT m a -> m b) -> StepT m a -> m b
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> m a -> StepT m a
forall (m :: * -> *) a.
Functor m =>
(a -> Bool) -> m a -> StepT m a
fromActionStep a -> Bool
stop m a
action)
{-# INLINE fromAction #-}
fromActionStep :: Functor m => (a -> Bool) -> m a -> StepT m a
fromActionStep :: (a -> Bool) -> m a -> StepT m a
fromActionStep stop :: a -> Bool
stop action :: m a
action = StepT m a
loop where
loop :: StepT m a
loop = m (StepT m a) -> StepT m a
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
Effect (m (StepT m a) -> StepT m a) -> m (StepT m a) -> StepT m a
forall a b. (a -> b) -> a -> b
$ (a -> StepT m a) -> m a -> m (StepT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> StepT m a
step m a
action
step :: a -> StepT m a
step x :: a
x
| a -> Bool
stop a
x = StepT m a
forall (m :: * -> *) a. StepT m a
Stop
| Bool
otherwise = a -> StepT m a -> StepT m a
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield a
x StepT m a
loop
{-# INLINE fromActionStep #-}
readFile :: FilePath -> SourceT IO BS.ByteString
readFile :: String -> SourceT IO ByteString
readFile fp :: String
fp =
(forall b. (StepT IO ByteString -> IO b) -> IO b)
-> SourceT IO ByteString
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
SourceT ((forall b. (StepT IO ByteString -> IO b) -> IO b)
-> SourceT IO ByteString)
-> (forall b. (StepT IO ByteString -> IO b) -> IO b)
-> SourceT IO ByteString
forall a b. (a -> b) -> a -> b
$ \k :: StepT IO ByteString -> IO b
k ->
String -> IOMode -> (Handle -> IO b) -> IO b
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
ReadMode ((Handle -> IO b) -> IO b) -> (Handle -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \hdl :: Handle
hdl ->
StepT IO ByteString -> IO b
k (Handle -> StepT IO ByteString
readHandle Handle
hdl)
where
readHandle :: Handle -> StepT IO BS.ByteString
readHandle :: Handle -> StepT IO ByteString
readHandle hdl :: Handle
hdl = (ByteString -> Bool) -> IO ByteString -> StepT IO ByteString
forall (m :: * -> *) a.
Functor m =>
(a -> Bool) -> m a -> StepT m a
fromActionStep ByteString -> Bool
BS.null (Handle -> Int -> IO ByteString
BS.hGet Handle
hdl 4096)
transformWithAtto :: Monad m => A.Parser a -> SourceT m BS.ByteString -> SourceT m a
transformWithAtto :: Parser a -> SourceT m ByteString -> SourceT m a
transformWithAtto parser :: Parser a
parser = (StepT m ByteString -> StepT m a)
-> SourceT m ByteString -> SourceT m a
forall (m :: * -> *) a b.
(StepT m a -> StepT m b) -> SourceT m a -> SourceT m b
mapStepT (Parser a -> StepT m ByteString -> StepT m a
forall a (m :: * -> *).
Monad m =>
Parser a -> StepT m ByteString -> StepT m a
transformStepWithAtto Parser a
parser)
transformStepWithAtto
:: forall a m. Monad m
=> A.Parser a -> StepT m BS.ByteString -> StepT m a
transformStepWithAtto :: Parser a -> StepT m ByteString -> StepT m a
transformStepWithAtto parser :: Parser a
parser = (ByteString -> Result a) -> StepT m ByteString -> StepT m a
go (Parser a -> ByteString -> Result a
forall a. Parser a -> ByteString -> Result a
A.parse Parser a
parser) where
p0 :: ByteString -> Result a
p0 = Parser a -> ByteString -> Result a
forall a. Parser a -> ByteString -> Result a
A.parse Parser a
parser
go :: (BS.ByteString -> A.Result a)
-> StepT m BS.ByteString -> StepT m a
go :: (ByteString -> Result a) -> StepT m ByteString -> StepT m a
go _ (Error err :: String
err) = String -> StepT m a
forall (m :: * -> *) a. String -> StepT m a
Error String
err
go p :: ByteString -> Result a
p (Skip s :: StepT m ByteString
s) = StepT m a -> StepT m a
forall (m :: * -> *) a. StepT m a -> StepT m a
Skip ((ByteString -> Result a) -> StepT m ByteString -> StepT m a
go ByteString -> Result a
p StepT m ByteString
s)
go p :: ByteString -> Result a
p (Effect ms :: m (StepT m ByteString)
ms) = m (StepT m a) -> StepT m a
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
Effect ((StepT m ByteString -> StepT m a)
-> m (StepT m ByteString) -> m (StepT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString -> Result a) -> StepT m ByteString -> StepT m a
go ByteString -> Result a
p) m (StepT m ByteString)
ms)
go p :: ByteString -> Result a
p Stop = case ByteString -> Result a
p ByteString
forall a. Monoid a => a
mempty of
A.Fail _ _ err :: String
err -> String -> StepT m a
forall (m :: * -> *) a. String -> StepT m a
Error String
err
A.Done _ a :: a
a -> a -> StepT m a -> StepT m a
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield a
a StepT m a
forall (m :: * -> *) a. StepT m a
Stop
A.Partial _ -> StepT m a
forall (m :: * -> *) a. StepT m a
Stop
go p :: ByteString -> Result a
p (Yield bs0 :: ByteString
bs0 s :: StepT m ByteString
s) = (ByteString -> Result a) -> ByteString -> StepT m a
loop ByteString -> Result a
p ByteString
bs0 where
loop :: (ByteString -> Result a) -> ByteString -> StepT m a
loop p' :: ByteString -> Result a
p' bs :: ByteString
bs
| ByteString -> Bool
BS.null ByteString
bs = StepT m a -> StepT m a
forall (m :: * -> *) a. StepT m a -> StepT m a
Skip ((ByteString -> Result a) -> StepT m ByteString -> StepT m a
go ByteString -> Result a
p' StepT m ByteString
s)
| Bool
otherwise = case ByteString -> Result a
p' ByteString
bs of
A.Fail _ _ err :: String
err -> String -> StepT m a
forall (m :: * -> *) a. String -> StepT m a
Error String
err
A.Done bs' :: ByteString
bs' a :: a
a -> a -> StepT m a -> StepT m a
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield a
a ((ByteString -> Result a) -> ByteString -> StepT m a
loop ByteString -> Result a
p0 ByteString
bs')
A.Partial p'' :: ByteString -> Result a
p'' -> StepT m a -> StepT m a
forall (m :: * -> *) a. StepT m a -> StepT m a
Skip ((ByteString -> Result a) -> StepT m ByteString -> StepT m a
go ByteString -> Result a
p'' StepT m ByteString
s)