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