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

-- | Arrows that have a strictness effect.
class (Arrow a) =>Strict a where
	-- | Laws:
	--
	-- * Either 'a' has arrow apply-constraint, or it is an application of an arrow transformer
	--  or both.
	--
	-- * Provided 'a' has arrow apply-constraint, force = 'forceDef'.
	-- 
	-- * Provided 'a' is an application of an arrow transformer, 'tmap' force is more defined
	-- (less strict) than force.
	--
	-- * 'force' has the unique most strict implementation which is compatible with the 
	--  previous laws.
	--
	-- These laws place limitations on the effects that 'force'
	-- can introduce. Reynolds' parametricity also implies that 'force'
	-- does not change the argument and return values.
	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 (Comonad f) => Strict(CoKleisli 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