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)

forceDef :: (ArrowApply a) => a t u -> a t u
{-# INLINE forceDef #-}
forceDef a = app.arr(\x -> x `seq` (a,x))

-- | Arrows that have a strictness effect.
class (Arrow a) =>Strict a where
	force :: a t u -> a 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