module Control.Monad.Hyper where
import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Monad.Fix
import Control.Monad.Zip
import Data.Coerce
import Data.Profunctor
import Prelude hiding ((.),id)
newtype Hyper a b = Hyper { invoke :: Hyper b a -> b }
unroll :: Hyper a b -> (Hyper a b -> a) -> b
unroll = coerce
roll :: ((Hyper a b -> a) -> b) -> Hyper a b
roll = coerce
ana :: (x -> (x -> a) -> b) -> x -> Hyper a b
ana psi = f where f x = Hyper $ \z -> psi x (invoke z . f)
cata :: (((x -> a) -> b) -> x) -> Hyper a b -> x
cata phi = f where f h = phi $ \g -> unroll h (g . f)
instance Category Hyper where
id = arr id
f . g = Hyper $ \k -> invoke f (g . k)
instance Profunctor Hyper where
dimap f g h = Hyper $ g . invoke h . dimap g f
lmap f h = Hyper $ invoke h . rmap f
rmap f h = Hyper $ f . invoke h . lmap f
instance Arrow Hyper where
arr = fix . push
first = ana $ \i fac -> (unroll i (fst . fac), snd (fac i))
second = ana $ \i fca -> (fst (fca i), unroll i (snd . fca))
(***) = curry $ ana $ \(i,j) fgac -> (unroll i $ \i' -> fst $ fgac (i',j), unroll j $ \j' -> snd $ fgac (i,j'))
(&&&) = curry $ ana $ \(i,j) fga -> (unroll i $ \i' -> fga (i',j), unroll j $ \j' -> fga (i,j'))
instance ArrowLoop Hyper where
loop = ana (flip f') where
f' fa = fmap fst $ fix $ \r -> flip unroll $ \i -> (fa i, snd $ r i)
instance Strong Hyper where
first' = first
second' = second
instance Costrong Hyper where
unfirst = loop
instance Functor (Hyper a) where
fmap = rmap
instance Applicative (Hyper a) where
pure a = Hyper $ \_ -> a
p <* _ = p
_ *> p = p
(<*>) = curry $ ana $ \(i,j) fga ->
unroll i (\i' -> fga (i',j)) $ unroll j (\j' -> fga (i,j'))
instance Monad (Hyper a) where
return = pure
m >>= f = cata (\g -> roll $ \k -> unroll (f (g k)) k) m
instance MonadZip (Hyper a) where
munzip h = (fmap fst h, fmap snd h)
mzipWith = liftA2
push :: (a -> b) -> Hyper a b -> Hyper a b
push f q = Hyper $ \k -> f (invoke k q)
run :: Hyper a a -> a
run f = invoke f id
project :: Hyper a b -> a -> b
project q x = invoke q (pure x)
fold :: [a] -> (a -> b -> c) -> c -> Hyper b c
fold xs c n = foldr (push . c) (pure n) xs
build :: (forall b c. (a -> b -> c) -> c -> Hyper b c) -> [a]
build g = run (g (:) [])