{- |
We try to mix effects of two completely unrelated arrows @a@ and @b@, where @b@ is considered pure, and @a@ — impure. Probably the most common use case would be @a = Kleisli IO@. We perform all the pure calculations first, and do the impure ones later.

Usage example:

>newtype Test input output = Test {runTest :: Mix (Kleisli IO) (Kleisli (State String)) input output}
>    deriving (Category, Arrow, ArrowChoice, ArrowLoop)
>
>runStateMorphism :: s -> Kleisli (State s) :~> (->)
>runStateMorphism s al i_input = evalState (runKleisli al i_input) s
>execTest :: Test input output -> input -> IO output
>execTest t = runKleisli $ arrCancelUnitFst $ unMix $ alongMap (runStateMorphism "") $ runTest $ first t
>
>rd = Test {runTest = liftImpure $ Kleisli $ const getLine}
>wr = Test {runTest = liftImpure $ Kleisli putStrLn}
>gt = Test {runTest = liftPure $ Kleisli $ const get}
>pt = Test {runTest = liftPure $ Kleisli put}
>
>test =
>    proc () ->
>        do line <- rd -< ()  -- effect from IO
>           pt -< line        -- effect from State
>           line' <- gt -< () -- effect from State
>           wr -< line'       -- effect from IO
-}
module Control.Arrow.Mix (Mix, liftImpure, liftPure, unMix, unMix') where
import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow
import Control.Arrow.Mix.Along
import Control.Arrow.Mix.Utilities
-- | @Mix a b@ is an arrow incapsulating both @a@ and @b@ effects. It's functorial in @b@.
data Mix a b input output where Mix :: (i -> o) -> (Along a i o :~> a) -> Along b i o input output -> Mix a b input output
-- | We can lift impure arrows
liftImpure :: (ArrowChoice a, ArrowLoop a, Arrow b) => a :~> Mix a b
liftImpure a = Mix Right (\al -> loop (al >>> second (a ||| id))) (arr (swap . first Left))
-- | Pure arrows can be lifted too
liftPure :: (Arrow a, Arrow b) => b :~> Mix a b
liftPure b = Mix id arrCancelUnitFst (first b)
-- | We need some way to extract the real computation from this @Mix@; fortunately, if we manage to reduce the pure arrow to a function (using @alongMap@), we can reduce the type @Mix a (->)@ to a.
unMix :: Arrow a => Mix a (->) :~> a
unMix = arrCancelUnitFst . unMix' . alongMap arr . first
-- | If, for some reason, the "pure" arrow is, in fact, as impure as the "impure" one, we still can extract the real computation.
unMix' :: Arrow a => Mix a a :~> a
unMix' (Mix _ a1 a2) = a1 a2
instance (Arrow a, Arrow b) => Category (Mix a b) where
    id = liftPure id
    Mix r2 a2 b2 . Mix r1 a1 b1 = Mix (r2 *** r1) (a2 . a1 . arrAssocRtoL) (arrAssocLtoR (twist ^>> first b1 >>> twist ^>> first b2))
instance (Arrow a, Arrow b) => Arrow (Mix a b) where
    arr = liftPure . arr
    first (Mix r a b) = Mix r a (arrTwist (first b))
instance (Arrow a, ArrowChoice b) => ArrowChoice (Mix a b) where
    left (Mix r a b) = Mix r a (f ^>> left b >>^ g) where
        f (Left input, i) = Left (input, i)
        f (Right z, i) = Right (z, i)
        g (Left (~(output, o))) = (Left output, o)
        g (Right (~(z, i))) = (Right z, r i)
instance (Arrow a, ArrowLoop b) => ArrowLoop (Mix a b) where
    loop (Mix r a b) = Mix r a (loop (arrTwist b))
instance AlongMap (Mix a) where
    alongMap h (Mix r a b) = Mix r a (arrTwist (h (arrTwist b)))