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