Shell.hs

{-# 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
    ) 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)
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
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 }

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) )

    fail _ = mzero

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))

#if MIN_VERSION_base(4,9,0)
instance Fail.MonadFail Shell where
    fail = Prelude.fail
#endif

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