{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes                #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}

{-| You can think of `Shell` as @[]@ + `IO` + `Managed`.  In fact, you can embed
    all three of them within a `Shell`:

> select ::        [a] -> Shell a
> liftIO ::      IO a  -> Shell a
> using  :: Managed a  -> Shell a

    Those three embeddings obey these laws:

> do { x <- select m; select (f x) } = select (do { x <- m; f x })
> do { x <- liftIO m; liftIO (f x) } = liftIO (do { x <- m; f x })
> do { x <- with   m; using  (f x) } = using  (do { x <- m; f x })
>
> select (return x) = return x
> liftIO (return x) = return x
> using  (return x) = return x

    ... and `select` obeys these additional laws:

> select xs <|> select ys = select (xs <|> ys)
> select empty = empty

    You typically won't build `Shell`s using the `Shell` constructor.  Instead,
    use these functions to generate primitive `Shell`s:

    * `empty`, to create a `Shell` that outputs nothing

    * `return`, to create a `Shell` that outputs a single value

    * `select`, to range over a list of values within a `Shell`

    * `liftIO`, to embed an `IO` action within a `Shell`

    * `using`, to acquire a `Managed` resource within a `Shell`
    
    Then use these classes to combine those primitive `Shell`s into larger
    `Shell`s:

    * `Alternative`, to concatenate `Shell` outputs using (`<|>`)

    * `Monad`, to build `Shell` comprehensions using @do@ notation

    If you still insist on building your own `Shell` from scratch, then the
    `Shell` you build must satisfy this law:

> -- For every shell `s`:
> _foldShell s (FoldShell step begin done) = do
>     x' <- _foldShell s (FoldShell step begin return)
>     done x'

    ... which is a fancy way of saying that your `Shell` must call @\'begin\'@
    exactly once when it begins and call @\'done\'@ exactly once when it ends.
-}

module Turtle.Shell (
    -- * Shell
      Shell(..)
    , FoldShell(..)
    , _foldIO
    , _Shell
    , foldIO
    , foldShell
    , fold
    , reduce
    , sh
    , view

    -- * Embeddings
    , select
    , liftIO
    , using
    , fromIO
    ) where

import Control.Applicative
import Control.Monad (MonadPlus(..), ap)
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Managed (MonadManaged(..), with)
import qualified Control.Monad.Fail as Fail
import Control.Foldl (Fold(..), FoldM(..))
import qualified Control.Foldl as Foldl
import Data.Foldable (Foldable)
import qualified Data.Foldable
import Data.Monoid
import Data.String (IsString(..))
import Prelude -- Fix redundant import warnings

{-| This is similar to @`Control.Foldl.FoldM` `IO`@ except that the @begin@
    field is pure

    This small difference is necessary to implement a well-behaved `MonadCatch`
    instance for `Shell`
-}
data FoldShell a b = forall x . FoldShell (x -> a -> IO x) x (x -> IO b)

-- | A @(Shell a)@ is a protected stream of @a@'s with side effects
newtype Shell a = Shell { Shell a -> forall r. FoldShell a r -> IO r
_foldShell:: forall r . FoldShell a r -> IO r }

data Maybe' a = Just' !a | Nothing'

translate :: FoldM IO a b -> FoldShell a b
translate :: FoldM IO a b -> FoldShell a b
translate (FoldM x -> a -> IO x
step IO x
begin x -> IO b
done) = (Maybe' x -> a -> IO (Maybe' x))
-> Maybe' x -> (Maybe' x -> IO b) -> FoldShell a b
forall a b x. (x -> a -> IO x) -> x -> (x -> IO b) -> FoldShell a b
FoldShell Maybe' x -> a -> IO (Maybe' x)
step' Maybe' x
forall a. Maybe' a
Nothing' Maybe' x -> IO b
done'
  where
    step' :: Maybe' x -> a -> IO (Maybe' x)
step' Maybe' x
Nothing' a
a = do
        x
x  <- IO x
begin
        x
x' <- x -> a -> IO x
step x
x a
a
        Maybe' x -> IO (Maybe' x)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe' x -> IO (Maybe' x)) -> Maybe' x -> IO (Maybe' x)
forall a b. (a -> b) -> a -> b
$! x -> Maybe' x
forall a. a -> Maybe' a
Just' x
x'
    step' (Just' x
x) a
a = do
        x
x' <- x -> a -> IO x
step x
x a
a
        Maybe' x -> IO (Maybe' x)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe' x -> IO (Maybe' x)) -> Maybe' x -> IO (Maybe' x)
forall a b. (a -> b) -> a -> b
$! x -> Maybe' x
forall a. a -> Maybe' a
Just' x
x'

    done' :: Maybe' x -> IO b
done' Maybe' x
Nothing' = do
        x
x <- IO x
begin
        x -> IO b
done x
x
    done' (Just' x
x) = do
        x -> IO b
done x
x

-- | Use a @`FoldM` `IO`@ to reduce the stream of @a@'s produced by a `Shell`
foldIO :: MonadIO io => Shell a -> FoldM IO a r -> io r
foldIO :: Shell a -> FoldM IO a r -> io r
foldIO Shell a
s FoldM IO a r
f = IO r -> io r
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Shell a -> FoldM IO a r -> IO r
forall a r. Shell a -> FoldM IO a r -> IO r
_foldIO Shell a
s FoldM IO a r
f)

{-| Provided for backwards compatibility with versions of @turtle-1.4.*@ and
    older
-}
_foldIO :: Shell a -> FoldM IO a r -> IO r
_foldIO :: Shell a -> FoldM IO a r -> IO r
_foldIO Shell a
s FoldM IO a r
foldM = Shell a -> FoldShell a r -> IO r
forall a. Shell a -> forall r. FoldShell a r -> IO r
_foldShell Shell a
s (FoldM IO a r -> FoldShell a r
forall a b. FoldM IO a b -> FoldShell a b
translate FoldM IO a r
foldM)

-- | Provided for ease of migration from versions of @turtle-1.4.*@ and older
_Shell :: (forall r . FoldM IO a r -> IO r) -> Shell a
_Shell :: (forall r. FoldM IO a r -> IO r) -> Shell a
_Shell forall r. FoldM IO a r -> IO r
f = (forall r. FoldShell a r -> IO r) -> Shell a
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (FoldM IO a r -> IO r
forall r. FoldM IO a r -> IO r
f (FoldM IO a r -> IO r)
-> (FoldShell a r -> FoldM IO a r) -> FoldShell a r -> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FoldShell a r -> FoldM IO a r
forall a b. FoldShell a b -> FoldM IO a b
adapt)
  where
    adapt :: FoldShell a b -> FoldM IO a b
adapt (FoldShell x -> a -> IO x
step x
begin x -> IO b
done) = (x -> a -> IO x) -> IO x -> (x -> IO b) -> FoldM IO a b
forall (m :: * -> *) a b x.
(x -> a -> m x) -> m x -> (x -> m b) -> FoldM m a b
FoldM x -> a -> IO x
step (x -> IO x
forall (m :: * -> *) a. Monad m => a -> m a
return x
begin) x -> IO b
done

-- | Use a `FoldShell` to reduce the stream of @a@'s produced by a `Shell`
foldShell :: MonadIO io => Shell a -> FoldShell a b -> io b
foldShell :: Shell a -> FoldShell a b -> io b
foldShell Shell a
s FoldShell a b
f = IO b -> io b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Shell a -> FoldShell a b -> IO b
forall a. Shell a -> forall r. FoldShell a r -> IO r
_foldShell Shell a
s FoldShell a b
f)

-- | Use a `Fold` to reduce the stream of @a@'s produced by a `Shell`
fold :: MonadIO io => Shell a -> Fold a b -> io b
fold :: Shell a -> Fold a b -> io b
fold Shell a
s Fold a b
f = Shell a -> FoldM IO a b -> io b
forall (io :: * -> *) a r.
MonadIO io =>
Shell a -> FoldM IO a r -> io r
foldIO Shell a
s (Fold a b -> FoldM IO a b
forall (m :: * -> *) a b. Monad m => Fold a b -> FoldM m a b
Foldl.generalize Fold a b
f)

-- | Flipped version of 'fold'. Useful for reducing a stream of data
--
-- ==== __Example__
-- Sum a `Shell` of numbers:
--
-- >>> select [1, 2, 3] & reduce Fold.sum
-- 6
reduce :: MonadIO io => Fold a b -> Shell a -> io b
reduce :: Fold a b -> Shell a -> io b
reduce = (Shell a -> Fold a b -> io b) -> Fold a b -> Shell a -> io b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Shell a -> Fold a b -> io b
forall (io :: * -> *) a b.
MonadIO io =>
Shell a -> Fold a b -> io b
fold

-- | Run a `Shell` to completion, discarding any unused values
sh :: MonadIO io => Shell a -> io ()
sh :: Shell a -> io ()
sh Shell a
s = Shell a -> Fold a () -> io ()
forall (io :: * -> *) a b.
MonadIO io =>
Shell a -> Fold a b -> io b
fold Shell a
s (() -> Fold a ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Run a `Shell` to completion, `print`ing any unused values
view :: (MonadIO io, Show a) => Shell a -> io ()
view :: Shell a -> io ()
view Shell a
s = Shell () -> io ()
forall (io :: * -> *) a. MonadIO io => Shell a -> io ()
sh (do
    a
x <- Shell a
s
    IO () -> Shell ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (a -> IO ()
forall a. Show a => a -> IO ()
print a
x) )

instance Functor Shell where
    fmap :: (a -> b) -> Shell a -> Shell b
fmap a -> b
f Shell a
s = (forall r. FoldShell b r -> IO r) -> Shell b
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\(FoldShell x -> b -> IO x
step x
begin x -> IO r
done) ->
        let step' :: x -> a -> IO x
step' x
x a
a = x -> b -> IO x
step x
x (a -> b
f a
a)
        in  Shell a -> FoldShell a r -> IO r
forall a. Shell a -> forall r. FoldShell a r -> IO r
_foldShell Shell a
s ((x -> a -> IO x) -> x -> (x -> IO r) -> FoldShell a r
forall a b x. (x -> a -> IO x) -> x -> (x -> IO b) -> FoldShell a b
FoldShell x -> a -> IO x
step' x
begin x -> IO r
done) )

instance Applicative Shell where
    pure :: a -> Shell a
pure  = a -> Shell a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: Shell (a -> b) -> Shell a -> Shell b
(<*>) = Shell (a -> b) -> Shell a -> Shell b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Shell where
    return :: a -> Shell a
return a
a = (forall r. FoldShell a r -> IO r) -> Shell a
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\(FoldShell x -> a -> IO x
step x
begin x -> IO r
done) -> do
       x
x <- x -> a -> IO x
step x
begin a
a
       x -> IO r
done x
x )

    Shell a
m >>= :: Shell a -> (a -> Shell b) -> Shell b
>>= a -> Shell b
f = (forall r. FoldShell b r -> IO r) -> Shell b
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\(FoldShell x -> b -> IO x
step0 x
begin0 x -> IO r
done0) -> do
        let step1 :: x -> a -> IO x
step1 x
x a
a = Shell b -> FoldShell b x -> IO x
forall a. Shell a -> forall r. FoldShell a r -> IO r
_foldShell (a -> Shell b
f a
a) ((x -> b -> IO x) -> x -> (x -> IO x) -> FoldShell b x
forall a b x. (x -> a -> IO x) -> x -> (x -> IO b) -> FoldShell a b
FoldShell x -> b -> IO x
step0 x
x x -> IO x
forall (m :: * -> *) a. Monad m => a -> m a
return)
        Shell a -> FoldShell a r -> IO r
forall a. Shell a -> forall r. FoldShell a r -> IO r
_foldShell Shell a
m ((x -> a -> IO x) -> x -> (x -> IO r) -> FoldShell a r
forall a b x. (x -> a -> IO x) -> x -> (x -> IO b) -> FoldShell a b
FoldShell x -> a -> IO x
step1 x
begin0 x -> IO r
done0) )

#if!(MIN_VERSION_base(4,13,0))
    fail = Fail.fail
#endif

instance Alternative Shell where
    empty :: Shell a
empty = (forall r. FoldShell a r -> IO r) -> Shell a
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\(FoldShell x -> a -> IO x
_ x
begin x -> IO r
done) -> x -> IO r
done x
begin)

    Shell a
s1 <|> :: Shell a -> Shell a -> Shell a
<|> Shell a
s2 = (forall r. FoldShell a r -> IO r) -> Shell a
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\(FoldShell x -> a -> IO x
step x
begin x -> IO r
done) -> do
        x
x <- Shell a -> FoldShell a x -> IO x
forall a. Shell a -> forall r. FoldShell a r -> IO r
_foldShell Shell a
s1 ((x -> a -> IO x) -> x -> (x -> IO x) -> FoldShell a x
forall a b x. (x -> a -> IO x) -> x -> (x -> IO b) -> FoldShell a b
FoldShell x -> a -> IO x
step x
begin x -> IO x
forall (m :: * -> *) a. Monad m => a -> m a
return)
        Shell a -> FoldShell a r -> IO r
forall a. Shell a -> forall r. FoldShell a r -> IO r
_foldShell Shell a
s2 ((x -> a -> IO x) -> x -> (x -> IO r) -> FoldShell a r
forall a b x. (x -> a -> IO x) -> x -> (x -> IO b) -> FoldShell a b
FoldShell x -> a -> IO x
step x
x x -> IO r
done) )

instance MonadPlus Shell where
    mzero :: Shell a
mzero = Shell a
forall (f :: * -> *) a. Alternative f => f a
empty

    mplus :: Shell a -> Shell a -> Shell a
mplus = Shell a -> Shell a -> Shell a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance MonadIO Shell where
    liftIO :: IO a -> Shell a
liftIO IO a
io = (forall r. FoldShell a r -> IO r) -> Shell a
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\(FoldShell x -> a -> IO x
step x
begin x -> IO r
done) -> do
        a
a <- IO a
io
        x
x <- x -> a -> IO x
step x
begin a
a
        x -> IO r
done x
x )

instance MonadManaged Shell where
    using :: Managed a -> Shell a
using Managed a
resource = (forall r. FoldShell a r -> IO r) -> Shell a
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\(FoldShell x -> a -> IO x
step x
begin x -> IO r
done) -> do
        x
x <- Managed a -> (a -> IO x) -> IO x
forall a r. Managed a -> (a -> IO r) -> IO r
with Managed a
resource (x -> a -> IO x
step x
begin)
        x -> IO r
done x
x )

instance MonadThrow Shell where
    throwM :: e -> Shell a
throwM e
e = (forall r. FoldShell a r -> IO r) -> Shell a
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\FoldShell a r
_ -> e -> IO r
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e)

instance MonadCatch Shell where
    Shell a
m catch :: Shell a -> (e -> Shell a) -> Shell a
`catch` e -> Shell a
k = (forall r. FoldShell a r -> IO r) -> Shell a
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\FoldShell a r
f-> Shell a -> FoldShell a r -> IO r
forall a. Shell a -> forall r. FoldShell a r -> IO r
_foldShell Shell a
m FoldShell a r
f IO r -> (e -> IO r) -> IO r
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\e
e -> Shell a -> FoldShell a r -> IO r
forall a. Shell a -> forall r. FoldShell a r -> IO r
_foldShell (e -> Shell a
k e
e) FoldShell a r
f))

instance Fail.MonadFail Shell where
    fail :: String -> Shell a
fail String
_ = Shell a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

#if __GLASGOW_HASKELL__ >= 804
instance Monoid a => Semigroup (Shell a) where
  <> :: Shell a -> Shell a -> Shell a
(<>) = Shell a -> Shell a -> Shell a
forall a. Monoid a => a -> a -> a
mappend
#endif

instance Monoid a => Monoid (Shell a) where
    mempty :: Shell a
mempty  = a -> Shell a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
    mappend :: Shell a -> Shell a -> Shell a
mappend = (a -> a -> a) -> Shell a -> Shell a -> Shell a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend

-- | Shell forms a semiring, this is the closest approximation
instance Monoid a => Num (Shell a) where
    fromInteger :: Integer -> Shell a
fromInteger Integer
n = [a] -> Shell a
forall (f :: * -> *) a. Foldable f => f a -> Shell a
select (Int -> a -> [a]
forall a. Int -> a -> [a]
replicate (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) a
forall a. Monoid a => a
mempty)

    + :: Shell a -> Shell a -> Shell a
(+) = Shell a -> Shell a -> Shell a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
    * :: Shell a -> Shell a -> Shell a
(*) = Shell a -> Shell a -> Shell a
forall a. Semigroup a => a -> a -> a
(<>)

instance IsString a => IsString (Shell a) where
    fromString :: String -> Shell a
fromString String
str = a -> Shell a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> a
forall a. IsString a => String -> a
fromString String
str)

-- | Convert a list to a `Shell` that emits each element of the list
select :: Foldable f => f a -> Shell a
select :: f a -> Shell a
select f a
as = (forall r. FoldShell a r -> IO r) -> Shell a
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\(FoldShell x -> a -> IO x
step x
begin x -> IO r
done) -> do
    let step' :: a -> (x -> IO b) -> x -> IO b
step' a
a x -> IO b
k x
x = do
            x
x' <- x -> a -> IO x
step x
x a
a
            x -> IO b
k (x -> IO b) -> x -> IO b
forall a b. (a -> b) -> a -> b
$! x
x'
    (a -> (x -> IO r) -> x -> IO r) -> (x -> IO r) -> f a -> x -> IO r
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Data.Foldable.foldr a -> (x -> IO r) -> x -> IO r
forall b. a -> (x -> IO b) -> x -> IO b
step' x -> IO r
done f a
as (x -> IO r) -> x -> IO r
forall a b. (a -> b) -> a -> b
$! x
begin )

-- | Convert an `IO` action that returns a `Maybe` into a `Shell`
fromIO :: IO (Maybe a) -> Shell a
fromIO :: IO (Maybe a) -> Shell a
fromIO IO (Maybe a)
io =
    (forall r. FoldShell a r -> IO r) -> Shell a
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell
        (\(FoldShell x -> a -> IO x
step x
begin x -> IO r
done) -> do
            let loop :: x -> IO r
loop x
x = do
                    Maybe a
m <- IO (Maybe a)
io
                    case Maybe a
m of
                        Just a
a -> do
                            x
x' <- x -> a -> IO x
step x
x a
a
                            x -> IO r
loop x
x'
                        Maybe a
Nothing -> do
                            x -> IO r
done x
x

            x -> IO r
loop x
begin
        )