{- |
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 input = evalState (runKleisli al 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', plusTwist, plusAssoc, plusCommute) 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 :~> a :+ b
liftImpure a = APlus $ Apply $ Mix Right (\al -> loop $ al >>> second (a ||| id)) (arr (first Left . swap))
-- | Pure arrows can be lifted too
liftPure :: (Arrow a, Arrow b) => b :~> a :+ b
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 @alMap@), 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 . second
    alLift h (Mix r1 a1 b) =
        case h r1 b of
          Mix r2 a2 c -> Mix (r2 *** r1) (a2 . a1 . arrAssocRtoL) (arrAssocRtoL c)
-- | (:+) is right commutative-associative: a :+ (b :+ c) and b :+ (a :+ c) can be reduced to one another with @plusTwist@ function
plusTwist :: (Arrow a, AlFunctor f, Arrow c) => a :+ f c :~> f (a :+ c)
plusTwist (APlus (Apply (Mix r a c))) = alMap (APlus . Apply . Mix r a . arrTwist) c
-- | (:+) is also associative
plusAssoc :: (Arrow a, Arrow b, Arrow c) => a :+ (b :+ c) :~> (a :+ b) :+ c
plusAssoc (APlus (Apply (Mix r a (APlus (Apply (Mix s b c)))))) = APlus (Apply (Mix (s *** r) (ab r a b) (arrAssocRtoL c)))
    where f :: ((a, (b, c)), d) -> (b, (c, (d, a)))
          f ~((a1, (b1, c1)), d1) = (b1, (c1, (d1, a1)))
          g :: (b, (c, (d, a))) -> ((a, (b, c)), d)
          g ~(b1, (c1, (d1, a1))) = ((a1, (b1, c1)), d1)
          ab :: (Arrow a, Arrow b) => (i -> o) -> (Along a i o :~> a) -> (Along b i' o' :~> b) -> (Along (a :+ b) (i', i) (o', o) :~> a :+ b)
          ab r1 a1 b1 (APlus (Apply (Mix r' a' b'))) = APlus (Apply (Mix (r1 *** r') (a1 . a' . arrAssocRtoL) (arrAssocRtoL $ b1 $ f ^>> b' >>^ g)))
-- | this function is experimental - no idea about how this would interact with other arrow combinators and functions defined in this module
plusCommute :: (Arrow a, ArrowChoice b, ArrowLoop b) => a :+ b :~> b :+ a
plusCommute = alMap unPlus . plusTwist . alMap liftImpure