MonoidObject.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PolyKinds                 #-}
{-# LANGUAGE RankNTypes                #-}

import           Control.Applicative
import           Control.Comonad
import           Control.Monad
import           Data.Functor.Compose
import           Data.Functor.Contravariant
import qualified Data.Functor.Contravariant.Day       as Contravariant
import           Data.Functor.Contravariant.Divisible
import qualified Data.Functor.Day                     as Covariant
import           Data.Functor.Identity
import qualified Data.Functor.Invariant.Day           as Invariant
import           Data.Functor.Product
import           Data.Void

newtype Nat f g =
  Nat { runNat :: forall a. f a -> g a }

newtype Flip f a b =
  Flip { runFlip :: f b a }

data MonoidObject p f a m =
  MonoidObject (p a m) (p (f m m) m)

type ComonoidObject p =
  MonoidObject (Flip p)

monoid ::
  Monoid a =>
  MonoidObject (->) (,) () a
monoid =
  MonoidObject (const mempty) (uncurry mappend)

applicative ::
  Applicative f =>
  MonoidObject Nat Covariant.Day Identity f
applicative =
  MonoidObject (Nat $ pure . runIdentity) (Nat $ \(Covariant.Day fa fb f) -> liftA2 f fa fb)

alternative ::
  Alternative f =>
  MonoidObject Nat Product Identity f
alternative =
  MonoidObject (Nat $ pure . runIdentity) (Nat $ \(Pair a b) -> a <|> b)

divisible ::
  Divisible f =>
  MonoidObject Nat Contravariant.Day (Const ()) f
divisible =
  MonoidObject (Nat $ const conquer) (Nat $ \(Contravariant.Day fb fc f) -> divide f fb fc)

data ContravariantEitherDay f g a =
  forall b c. ContravariantEitherDay (f b) (g c) (a -> Either b c)

decidable ::
  Decidable f =>
  MonoidObject Nat ContravariantEitherDay (Op Void) f
decidable =
  MonoidObject (Nat $ lose . getOp) (Nat $ \(ContravariantEitherDay fb fc f) -> choose f fb fc)

monad ::
  Monad f =>
  MonoidObject Nat Compose Identity f
monad =
  MonoidObject (Nat $ pure . runIdentity) (Nat $ join . getCompose)

comonad ::
  Comonad f =>
  ComonoidObject Nat Compose Identity f
comonad =
  MonoidObject (Flip $ Nat $ Identity . extract) (Flip $ Nat $ Compose . duplicate)

class Invariant f => Refurbish f where
  renovate :: (a -> b -> c) -> (c -> (a, b)) -> f a -> f b -> f c

refurbish ::
  Refurbish f =>
  MonoidObject Nat Invariant.Day Identity f
refurbish =
  MonoidObject (Nat $ pure . runIdentity) (Nat $ \(Invariant.Day fb fc bca abc) -> renovate bca abc fb fc)