elab.hs

{-# LANGUAGE DerivingVia, GADTs #-}

import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow
import Data.Monoid

-- Endo for categories - not in base yet
newtype EndoC c a = EndoC { appEndoC :: c a a }
instance (Category c) => Semigroup (EndoC c a) where
  EndoC f <> EndoC g = EndoC (f . g)
instance (Category c) => Monoid (EndoC c a) where
  mempty = EndoC id
-- end boilerplate

newtype Elab m c a b = Elab (a -> m (b, c a b))

instance (Category c, Monad m) => Category (Elab m c) where
  id = Elab (\x -> pure (x, id))
  (Elab f) . (Elab g) =
    Elab (\x -> do
      (y, h) <- g x
      (z, h') <- f y
      pure (z, h' . h))

deriving via (EndoC (Elab m c) a)
  instance (Category c, Monad m, a ~ b) => Semigroup (Elab m c a b)

deriving via (EndoC (Elab m c) a)
  instance (Category c, Monad m, a ~ b) => Monoid (Elab m c a b)