Freer.hs

{-# LANGUAGE Arrows                #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE Rank2Types            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

module Control.Arrow.Free
  ( Freer(..)
  ) where

import           Control.Arrow
import           Control.Category
import           Data.Bool        (Bool)
import           Data.Either      (Either (..))
import           Data.Function    (const, flip, ($))
import           Data.List        (uncons)
import           Data.Maybe       (maybe)
import           Data.Tuple       (uncurry)
import           GHC.Exts         (Constraint)

type x ~> y = forall a b. x a b -> y a b

newtype Freer cst eff a b = Freer {
  runFreer :: forall x. cst x => (eff ~> x) -> x a b
}

instance Category (Freer Category eff) where
  id = Freer $ const id
  Freer f . Freer g = Freer $ \x -> f x . g x
instance Category (Freer Arrow eff) where
  id = id
  (.) = (.)
instance Category (Freer ArrowChoice eff) where
  id = id
  (.) = (.)

instance Arrow (Freer Arrow eff) where
  arr a = Freer $ const $ arr a
  first (Freer a) = Freer $ \f -> first (a f)
  second (Freer a) = Freer $ \f -> second (a f)
  (Freer a) *** (Freer b) = Freer $ \f -> a f *** b f
instance Arrow (Freer ArrowChoice eff) where
  arr = arr
  first = first
  second = second
  (***) = (***)

instance ArrowChoice (Freer ArrowChoice eff) where
  left (Freer a) = Freer $ \f -> left (a f)
  right (Freer a) = Freer $ \f -> right (a f)
  (Freer a) ||| (Freer b) = Freer $ \f -> a f ||| b f