module Control.Arrow.Mix.Category (Along, (:~>), (:~~>), AlMonad(..), (~>>=), AlFunctor(..), OhNo, (:$~)(..)) where
import Prelude hiding (id, (.))
import Control.Arrow
import Control.Category
import Control.Arrow.Mix.Utilities
-- | Arrow morphism
type f :~> g = forall i o. f i o -> g i o
infixr 0 :~>
-- | Refined arrow morphism
type f :~~> g = forall i o. (i -> o) -> f i o -> g i o
infixr 0 :~~>
-- | Sometimes we need to refine our morphism a bit; therefore, we use @Along f i o@ instead of just @f@.
type Along f input output i o = f (i, input) (o, output)
-- | Something like a monad - but for arrows
class AlMonad m where
    alRet :: Arrow b => b :~> m b
    alLift :: (Arrow b, Arrow c) => (Along b i1 o1 :~~> Along (m c) i2 o2) -> (m b i1 o1 -> m c i2 o2)
-- | Most of time we don't need refined morphisms. That's why we would want a simpler combinator.
(~>>=) :: (AlMonad m, Arrow b, Arrow c) => m b i1 o1 -> (Along b i1 o1 :~> Along (m c) i2 o2) -> m c i2 o2
m ~>>= h = alLift (const h) m
infixl 1 ~>>=
-- | Something like a functor - again, for arrows
class AlFunctor f where
    alMap :: (Arrow b, Arrow c) => (Along b i1 o1 :~> Along c i2 o2) -> (f b i1 o1 -> f c i2 o2)
-- | Just a trick to avoid specifying rank explicitly
type OhNo a b = b
-- | Declarations like @instance Monad m => Functor m@ don't work well in Haskell. That's why we need a newtype.
newtype (f :$~ a) input output = Apply {runApply :: a input output `OhNo` f a input output} deriving AlMonad
infixl 0 :$~
instance AlMonad m => AlFunctor ((:$~) m) where
    alMap h m = m ~>>= \b -> alRet $ h b
instance (AlMonad m, Arrow a) => Category (m :$~ a) where
    id = alRet id
    m2 . m1 = m1 ~>>= \a1 -> m2 ~>>= \a2 -> alRet $ a1 ->> a2
instance (AlMonad m, Arrow a) => Arrow (m :$~ a) where
    arr = alRet . arr
    first m = m ~>>= \a -> alRet $ arrAssocLtoR $ first a
instance (AlMonad m, ArrowLoop a) => ArrowLoop (m :$~ a) where
    loop m = m ~>>= \a -> alRet $ loop $ arrAssocRtoL $ a
instance (AlMonad m, ArrowChoice a) => ArrowChoice (m :$~ a) where
    left = alLift $ \t a -> alRet $ arrUnpack $ a +++ arr (first t)