{- |
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 :: (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 $ unPlus $ alMap (runStateMorphism "") $ runTest 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 (module Control.Arrow.Mix.Category, (:+), liftImpure, liftPure, unPlus, unPlus') where
import Prelude hiding (id, (.))
import Control.Arrow
import Control.Category
import Control.Arrow.Mix.Category
import Control.Arrow.Mix.Utilities
data Mix a b input output where Mix :: (i -> o) -> (Along a i o :~> a) -> Along b input output i o -> Mix a b input output
-- | @a :+ b@ is an arrow incapsulating both @a@ and @b@ effects. It's functorial (and even monadic) in @b@.
newtype (a :+ b) input output = APlus ((Mix a :$~ b) input output) deriving (AlMonad, AlFunctor, Category, Arrow, ArrowLoop, ArrowChoice)
infixl 6 :+
-- | We can lift impure arrows
liftImpure :: (ArrowChoice a, ArrowLoop a, Arrow b) => a input output -> (a :+ b) input output
liftImpure a = APlus $ Apply $ Mix Right (\al -> loop $ arrSwap al >>> second ( a ||| id)) (arr (swap . first Left))
-- | Pure arrows can be lifted too
liftPure :: (Arrow a, Arrow b) => b input output -> (a :+ b) input output
liftPure = alRet
-- | We need some way to extract the real computation from this @:+@; fortunately, if we manage to reduce the pure arrow to a function (using @alongMap@), we can reduce the type @a :+ (->)@ to @a@.
unPlus :: Arrow a => a :+ (->) :~> a
unPlus = unPlus' . alMap arr
-- | If, for some reason, the "pure" arrow is, in fact, as impure as the "impure" one, we still can extract the real computation.
unPlus' :: Arrow a => a :+ a :~> a
unPlus' (APlus (Apply (Mix _ a1 a2))) = a1 $ arrSwap a2
instance Arrow a => AlMonad (Mix a) where
    alRet = Mix id arrCancelUnit . first
    alLift h (Mix r1 a1 b) =
        case h r1 b of
          Mix r2 a2 c -> Mix (r1 *** r2) (a2 . a1 . arrAssoc) (arrAssoc c)