{-# 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

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Control.Monad.Except (runExcept)
-- >>> import Data.Foldable (toList)
-- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8

-- | This is CPSised ListT.
--
-- @since 0.15
--
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 #-}

-- | @ListT@ with additional constructors.
--
-- @since 0.15
--
data StepT m a
    = Stop
    | Error String      -- we can this argument configurable.
    | Skip (StepT m a)  -- Note: not sure about this constructor
    | 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

-- | Create 'SourceT' from 'Step'.
--
-- /Note:/ often enough you want to use 'SourceT' directly.
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)

-------------------------------------------------------------------------------
-- SourceT instances
-------------------------------------------------------------------------------

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)

-- | >>> toList (source [1..10])
-- [1,2,3,4,5,6,7,8,9,10]
--
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

-- | >>> hoist (Just . runIdentity) (source [1..3]) :: SourceT Maybe Int
-- fromStepT (Effect (Just (Yield 1 (Yield 2 (Yield 3 Stop)))))
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

-- | >>> source "xy" <> source "z" :: SourceT Identity Char
-- fromStepT (Effect (Identity (Yield 'x' (Yield 'y' (Yield 'z' Stop)))))
--
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

-- | >>> mempty :: SourceT Maybe Int
-- fromStepT (Effect (Just Stop))
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
(<>)

-- | Doesn't generate 'Error' constructors. 'SourceT' doesn't shrink.
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

-- An example of above instance. Not doctested because it's volatile.
--
-- >>> import Test.QuickCheck as QC
-- >>> import Test.QuickCheck.Gen as QC
-- >>> import Test.QuickCheck.Random as QC
-- >>> let generate (QC.MkGen g) = g (QC.mkQCGen 44) 10
--
-- >>> generate (arbitrary :: QC.Gen (SourceT Identity Int))
-- fromStepT (Effect (Identity (Yield (-10) (Yield 3 (Skip (Yield 1 Stop))))))

-------------------------------------------------------------------------------
-- StepT instances
-------------------------------------------------------------------------------

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

-- | >>> lift [1,2,3] :: StepT [] Int
-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]
--
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)

-- | >>> mempty :: StepT [] Int
-- Stop
--
-- >>> mempty :: StepT Identity Int
-- Stop
--
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
(<>)

-- | Doesn't generate 'Error' constructors.
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 ]

-------------------------------------------------------------------------------
-- Operations
-------------------------------------------------------------------------------

-- | Create pure 'SourceT'.
--
-- >>> source "foo" :: SourceT Identity Char
-- fromStepT (Effect (Identity (Yield 'f' (Yield 'o' (Yield 'o' Stop)))))
--
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

-- | Get the answers.
--
-- >>> runSourceT (source "foo" :: SourceT Identity Char)
-- ExceptT (Identity (Right "foo"))
--
-- >>> runSourceT (source "foo" :: SourceT [] Char)
-- ExceptT [Right "foo"]
--
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

{-
-- | >>> uncons (foldr Yield Stop "foo" :: StepT Identity Char)
-- Identity (Just ('f',Yield 'o' (Yield 'o' Stop)))
--
uncons :: Monad m => StepT m a -> m (Maybe (a, StepT m a))
uncons Stop        = return Nothing
uncons (Skip s)    = uncons s
uncons (Yield x s) = return (Just (x, s))
uncons (Effect ms) = ms >>= uncons
uncons (Error _) =
-}

-- | Filter values.
--
-- >>> toList $ mapMaybe (\x -> if odd x then Just x else Nothing) (source [0..10]) :: [Int]
-- [1,3,5,7,9]
--
-- >>> mapMaybe (\x -> if odd x then Just x else Nothing) (source [0..2]) :: SourceT Identity Int
-- fromStepT (Effect (Identity (Skip (Yield 1 (Skip Stop)))))
--
-- Illustrates why we need 'Skip'.
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)

-- | Run action for each value in the 'SourceT'.
--
-- >>> foreach fail print (source "abc")
-- 'a'
-- 'b'
-- 'c'
--
foreach
    :: Monad m
    => (String -> m ())  -- ^ error handler
    -> (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)

-- | See 'foreach'.
foreachStep
    :: Monad m
    => (String -> m ())  -- ^ error handler
    -> (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

-------------------------------------------------------------------------------
-- Monadic
-------------------------------------------------------------------------------

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 #-}

-------------------------------------------------------------------------------
-- File
-------------------------------------------------------------------------------

-- | Read file.
--
-- >>> foreach fail BS.putStr (readFile "servant.cabal")
-- cabal-version:       >=1.10
-- name:                servant
-- ...
--
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)

-------------------------------------------------------------------------------
-- Attoparsec
-------------------------------------------------------------------------------

-- | Transform using @attoparsec@ parser.
--
-- Note: @parser@ should not accept empty input!
--
-- >>> let parser = A.skipWhile A8.isSpace_w8 >> A.takeWhile1 A8.isDigit_w8
--
-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1 2 3"])
-- Right ["1","2","3"]
--
-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2", "3"])
-- Right ["123"]
--
-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2 3", "4"])
-- Right ["12","34"]
--
-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["foobar"])
-- Left "Failed reading: takeWhile1"
--
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)