Shell.hs

{-# 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 { _foldShell:: forall r . FoldShell a r -> IO r }

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

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

    done' Nothing' = do
        x <- begin
        done x
    done' (Just' x) = do
        done 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 s f = liftIO (_foldIO s f)

{-| Provided for backwards compatibility with versions of @turtle-1.4.*@ and
    older
-}
_foldIO :: Shell a -> FoldM IO a r -> IO r
_foldIO s foldM = _foldShell s (translate 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 f = Shell (f . adapt)
  where
    adapt (FoldShell step begin done) = FoldM step (return begin) 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 s f = liftIO (_foldShell s 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 s f = foldIO s (Foldl.generalize 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 = flip fold

-- | Run a `Shell` to completion, discarding any unused values
sh :: MonadIO io => Shell a -> io ()
sh s = fold s (pure ())

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

instance Functor Shell where
    fmap f s = Shell (\(FoldShell step begin done) ->
        let step' x a = step x (f a)
        in  _foldShell s (FoldShell step' begin done) )

instance Applicative Shell where
    pure  = return
    (<*>) = ap

instance Monad Shell where
    return a = Shell (\(FoldShell step begin done) -> do
       x <- step begin a
       done x )

    m >>= f = Shell (\(FoldShell step0 begin0 done0) -> do
        let step1 x a = _foldShell (f a) (FoldShell step0 x return)
        _foldShell m (FoldShell step1 begin0 done0) )

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

instance Alternative Shell where
    empty = Shell (\(FoldShell _ begin done) -> done begin)

    s1 <|> s2 = Shell (\(FoldShell step begin done) -> do
        x <- _foldShell s1 (FoldShell step begin return)
        _foldShell s2 (FoldShell step x done) )

instance MonadPlus Shell where
    mzero = empty

    mplus = (<|>)

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

instance MonadManaged Shell where
    using resource = Shell (\(FoldShell step begin done) -> do
        x <- with resource (step begin)
        done x )

instance MonadThrow Shell where
    throwM e = Shell (\_ -> throwM e)

instance MonadCatch Shell where
    m `catch` k = Shell (\f-> _foldShell m f `catch` (\e -> _foldShell (k e) f))

instance Fail.MonadFail Shell where
    fail _ = mzero

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

instance Monoid a => Monoid (Shell a) where
    mempty  = pure mempty
    mappend = liftA2 mappend

-- | Shell forms a semiring, this is the closest approximation
instance Monoid a => Num (Shell a) where
    fromInteger n = select (replicate (fromInteger n) mempty)

    (+) = (<|>)
    (*) = (<>)

instance IsString a => IsString (Shell a) where
    fromString str = pure (fromString str)

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

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

            loop begin
        )