{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
module Turtle.Shell (
Shell(..)
, FoldShell(..)
, _foldIO
, _Shell
, foldIO
, foldShell
, fold
, reduce
, sh
, view
, 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)
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
data FoldShell a b = forall x . FoldShell (x -> a -> IO x) x (x -> IO b)
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
foldIO :: MonadIO io => Shell a -> FoldM IO a r -> io r
foldIO s f = liftIO (_foldIO s f)
_foldIO :: Shell a -> FoldM IO a r -> IO r
_foldIO s foldM = _foldShell s (translate foldM)
_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
foldShell :: MonadIO io => Shell a -> FoldShell a b -> io b
foldShell s f = liftIO (_foldShell s f)
fold :: MonadIO io => Shell a -> Fold a b -> io b
fold s f = foldIO s (Foldl.generalize f)
reduce :: MonadIO io => Fold a b -> Shell a -> io b
reduce = flip fold
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 (\(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
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 :: 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 )