module Control.CUtils.StrictArrow where
import Control.Arrow
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Writer
import Control.Arrow.Abort
import Control.Arrow.Transformer
import Control.Category
import Prelude hiding ((.), id)
type ProfunctorOptic a t u v w = a v w -> a t u
forceDef :: (ArrowApply a) => ProfunctorOptic a t u t u
{-# INLINE forceDef #-}
forceDef a = app.arr((,) a $!)
class (Arrow a) =>Strict a where
force :: ProfunctorOptic a t u t u
evalInFst :: (t,u) -> (t,u)
{-# INLINE evalInFst #-}
evalInFst pair@(x,_) = x`seq` pair
instance Strict(->) where
force = forceDef
instance (Monad f) => Strict(Kleisli f) where
force = forceDef
instance (Strict a) => Strict(ReaderT r a) where
force (ReaderT a) = ReaderT(force a.arr evalInFst)
instance (Strict a) => Strict(StateT s a) where
force (StateT a) = StateT(force a. arr evalInFst)
instance (Strict a, Monoid w) => Strict(WriterT w a) where
force = tmap force
instance (Strict a, ArrowChoice a) => Strict(AbortT r a) where
force = tmap force