par-seq.hs

-- === The Abstract ===

-- | A wrapper for `Applicative`-only semantics for types that also have a
--  `Monad`.
newtype Par m a = Par { unPar :: m a }

-- | A wrapper for `Monad` semantics for types that have a distinct
--  `Applicative`.
newtype Seq m a = Seq { unSeq :: m a }

instance Functor f => Functor (Par f) where
  fmap f a = Par . fmap f $ unPar a

instance Functor f => Functor (Seq f) where
  fmap f a = Seq . fmap f $ unSeq a

-- TODO: If I understood `ala` better, I might avoid these custom functions.

-- | The `Monad`-incompatible `<*>` operation.
(<\>) :: Applicative (Par f) => f (a -> b) -> f a -> f b
f <\> a = unPar $ Par f <*> Par a

-- | The `Monad`-compatible `<*>` operation.
(</>) :: Applicative (Seq f) => f (a -> b) -> f a -> f b
f </> a = unSeq $ Seq f <*> Seq a

-- | `>>=` applied to something with distinct `Applicative` semantics.
(>/=) :: Monad (Seq f) => f a -> (a -> f b) -> f b
ma >/= f = unSeq $ Seq ma >>= Seq . f

-- === The Concrete ===

-- Like `Either`, but without `Applicative` and `Monad` instances.
data Disj a b = Fst a | Snd b

instance Functor (Disj a) where
  fmap _ (Fst a) = Fst a
  fmap f (Snd b) = Snd $ f b

instance Semigroup a => Applicative (Par (Disj a)) where
  pure = Par . Snd
  Par f <*> Par a =
    Par
    $ case (f, a) of
        (Fst f', Fst a') -> Fst $ f' <> a'
        (Fst f', Snd _) -> Fst f'
        (Snd _, Fst a') -> Fst a'
        (Snd f', Snd a') -> Snd $ f' a'

instance Applicative (Seq (Disj a)) where
  pure = Seq . Snd
  Seq f <*> Seq a =
    Seq
    $ case (f, a) of
        (Fst f', _)     -> Fst f'
        (Snd _, Fst a') -> Fst a'
        (Snd f', Snd a') -> Snd $ f' a'

instance Monad (Seq (Disj a)) where
  Seq (Fst a) >>= _ = Seq $ Fst a
  Seq (Snd b) >>= f = f b