Hyperfunction.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall -Werror -Wextra #-}

module Hyperfunction where

import Control.Category
import Data.Function (fix)
import Prelude hiding (id, (.))

newtype a -&> b = Hyp ((b -&> a) -> b)

invoke :: (a -&> b) -> (b -&> a) -> b
invoke (Hyp f) = f

instance Category (-&>) where
  id = Hyp (\k -> invoke k id)
  f . g = Hyp (\k -> invoke f (g . k))

push :: (a -> b) -> a -&> b -> a -&> b
push f q = Hyp (\k -> f (invoke k q))

data a -|> b = (a -> b) :- (a -|> b)

instance Category (-|>) where
  id = always id
  (f :- fs) . (g :- gs) = (f . g) :- (fs . gs)

always :: (a -> b) -> (a -|> b)
always f = fix (f :-)

eval :: (a -|> b) -> (b -|> a) -> b
eval (f :- fs) gs = f (eval gs fs)

from :: (a -|> b) -> (a -&> b)
from (f :- fs) = push f (from fs)

to :: (a -&> b) -> (a -|> b)
to h = always \b -> invoke h (from (always (const b)))

-- CLAIM: eval fs gs == invoke (from fs) (from gs)
-- CLAIM: to . from == id
-- CLAIM: from . to != id