shitty coeffects

coeffects.hs

{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}

------------------------------------------------------------------------------
-- | Magic (aka shitty) implementation of coeffects over standard Haskell arrow
-- types.
module Note where

import Data.Functor.Identity
import qualified Control.Category as C
import Prelude hiding ((.), id)
import Data.Monoid ((<>))
import GHC.Generics hiding (Selector)

class LiftJuice z s where
  juice :: s a b -> IxF z a b

instance LiftJuice z (IxF z) where
  juice = C.id
  {-# INLINE juice #-}

instance Monoid z => LiftJuice z (->) where
  juice = tagged mempty
  {-# INLINE juice #-}

(.) :: (Monoid z, LiftJuice z s, LiftJuice z t) => t b c -> s a b -> IxF z a c
b . a = juice b C.. juice a
{-# INLINE (.) #-}

data IxF z a b = IxF
  { runIxF :: a -> b
  , ixfC :: z
  }

instance Monoid z => C.Category (IxF z) where
  id = IxF C.id mempty
  b . a = IxF (runIxF b C.. runIxF a)
              (ixfC b <> ixfC a)

tagged :: z -> (a -> b) -> IxF z a b
tagged = flip IxF

data Note = Note

name :: IxF String a String
name = tagged "name" $ const "hello"

getTags :: LiftJuice z s => s a b -> z
getTags = ixfC C.. juice


type family Selector f a where
  Selector Identity a = a
  Selector f a = f a

data X f = X { getFoo :: Selector f String }

class GetCoeffects s where
  getCoeffects :: s (IxF [String] (s Identity))