module Data.Thrist (
Thrist (..)
, Flipped (..)
, mapThrist
, foldrThrist
, foldlThrist
, foldr1Thrist
, foldl1Thrist
, mapMThrist
, foldMThrist
, appendThrist
, nullThrist
, lengthThrist
) where
import Prelude hiding ((.), id)
import Control.Category
import Data.Monoid
import Control.Arrow
import Control.Monad
data Thrist :: (k -> k -> *) -> k -> k -> * where
Nil :: Thrist arr a a
Cons :: (a `arr` b) -> Thrist arr b c -> Thrist arr a c
instance Monoid (Thrist arr a a) where
mempty = Nil
mappend = appendThrist
instance (Arrow arr) => Arrow (Thrist arr) where
arr f = Cons (arr f) Nil
first Nil = Nil
first t = Cons ((foldrThrist (flip (.)) id t) *** id) Nil
instance Category (Thrist arr) where
id = Nil
b . a = appendThrist a b
newtype Flipped m a b = Flipped { unflip :: m b a }
foldrThrist :: (forall i j . (i `arr` j) -> (j `brr` c) -> (i `brr` c))
-> (b `brr` c)
-> Thrist arr a b
-> (a `brr` c)
foldrThrist _ v Nil = v
foldrThrist f v (Cons h t) = h `f` (foldrThrist f v t)
appendThrist :: Thrist arr a b -> Thrist arr b c -> Thrist arr a c
appendThrist = flip (foldrThrist Cons)
mapThrist :: (forall i j . (i `brr` j) -> (i `arr` j))
-> Thrist brr a b
-> Thrist arr a b
mapThrist f = foldrThrist (Cons . f) Nil
foldlThrist :: (forall j k . (a `brr` j) -> (j `arr` k) -> (a `brr` k))
-> (a `brr` b)
-> Thrist arr b c
-> (a `brr` c)
foldlThrist _ v Nil = v
foldlThrist f v (Cons h t) = foldlThrist f (v `f` h) t
foldl1Thrist :: (forall i j k. (i `arr` j) -> (j `arr` k) -> (i `arr` k))
-> Thrist arr a b
-> (a `arr` b)
foldl1Thrist f (Cons a th) = foldlThrist f a th
foldl1Thrist _ Nil = error "empty thrist"
foldr1Thrist :: (forall i j k. (i `arr` j) -> (j `arr` k) -> (i `arr` k))
-> Thrist arr a b
-> (a `arr` b)
foldr1Thrist _ (Cons b Nil) = b
foldr1Thrist f (Cons a th) = f a $ foldr1Thrist f th
foldr1Thrist _ Nil = error "empty thrist"
mapMThrist :: Monad m =>
(forall i j . (i `brr` j) -> m (i `arr` j))
-> Thrist brr a b
-> m (Thrist arr a b)
mapMThrist _ Nil = return Nil
mapMThrist f (Cons h t) = liftM2 Cons (f h) (mapMThrist f t)
foldMThrist :: Monad m =>
(forall j k . (a `brr` j) -> (j `arr` k) -> m (a `brr` k))
-> (a `brr` b)
-> Thrist arr b c
-> m (a `brr` c)
foldMThrist _ a Nil = return a
foldMThrist f a (Cons h t) = f a h >>= \fah -> foldMThrist f fah t
nullThrist :: Thrist arr a b -> Bool
nullThrist Nil = True
nullThrist _ = False
lengthThrist :: Thrist arr a b -> Int
lengthThrist Nil = 0
lengthThrist (Cons _ rest) = 1 + lengthThrist rest