module Turtle.Shell (
Shell(..)
, foldIO
, fold
, sh
, view
, select
, liftIO
, using
) where
import Control.Applicative
import Control.Monad (MonadPlus(..), ap)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Managed (MonadManaged(..), with)
import Control.Foldl (Fold(..), FoldM(..))
import qualified Control.Foldl as Foldl
import Data.Monoid
import Data.String (IsString(..))
import Prelude
newtype Shell a = Shell { _foldIO :: forall r . FoldM IO a r -> IO r }
foldIO :: MonadIO io => Shell a -> FoldM IO a r -> io r
foldIO s f = liftIO (_foldIO s f)
fold :: MonadIO io => Shell a -> Fold a b -> io b
fold s f = foldIO s (Foldl.generalize f)
sh :: MonadIO io => Shell a -> io ()
sh s = fold s (pure ())
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 (\(FoldM step begin done) ->
let step' x a = step x (f a)
in _foldIO s (FoldM step' begin done) )
instance Applicative Shell where
pure = return
(<*>) = ap
instance Monad Shell where
return a = Shell (\(FoldM step begin done) -> do
x <- begin
x' <- step x a
done x' )
m >>= f = Shell (\(FoldM step0 begin0 done0) -> do
let step1 x a = _foldIO (f a) (FoldM step0 (return x) return)
_foldIO m (FoldM step1 begin0 done0) )
fail _ = mzero
instance Alternative Shell where
empty = Shell (\(FoldM _ begin done) -> do
x <- begin
done x )
s1 <|> s2 = Shell (\(FoldM step begin done) -> do
x <- _foldIO s1 (FoldM step begin return)
_foldIO s2 (FoldM step (return x) done) )
instance MonadPlus Shell where
mzero = empty
mplus = (<|>)
instance MonadIO Shell where
liftIO io = Shell (\(FoldM step begin done) -> do
x <- begin
a <- io
x' <- step x a
done x' )
instance MonadManaged Shell where
using resource = Shell (\(FoldM step begin done) -> do
x <- begin
x' <- with resource (step x)
done x' )
instance Monoid a => Monoid (Shell a) where
mempty = pure mempty
mappend = liftA2 mappend
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)
select :: [a] -> Shell a
select as = Shell (\(FoldM step begin done) -> do
x0 <- begin
let step' a k x = do
x' <- step x a
k $! x'
foldr step' done as $! x0 )