thrist-0.1.1: Data/Thrist.hs

module Data.Thrist ( Thrist (..)
                   , foldThrist
                   , appendThrist
                   , mapThrist ) where

import Prelude
import Data.Monoid
import Control.Category
-- import Data.Char
import Control.Arrow

data Thrist :: (* -> * -> *) -> * -> * -> * where
  Nil :: Thrist (~>) a a
  Cons :: (a ~> b) -> Thrist (~>) b c -> Thrist (~>) a c


foldThrist :: (forall i j k . (i ~> j) -> (j ~> k) -> (i ~> k))
              -> c ~> c
              -> Thrist (~>) a c
              -> a ~> c
foldThrist _ v Nil = v
foldThrist f v (Cons h t) = h `f` (foldThrist f v t)

{- Simple demo:
t1 :: Thrist (->) Char Char
t1 = ord `Cons` ((\i -> i+32) `Cons` (chr `Cons` Nil))

t2 :: Char -> Char
t2 = foldThrist (flip (.)) id t1
-}

appendThrist :: forall ((~>) :: * -> * -> *) a b c .
                Thrist (~>) a b ->
                Thrist (~>) b c ->
                Thrist (~>) a c

appendThrist Nil a = a
appendThrist (Cons b r) a = Cons b (appendThrist r a)

mapThrist :: (forall i j . i +> j -> i ~> j) -> Thrist (+>) a b -> Thrist (~>) a b
mapThrist _ Nil = Nil
mapThrist f (Cons a r) = Cons (f a) (mapThrist f r)


instance Monoid (Thrist (~>) a a) where
  mempty = Nil
  mappend = appendThrist

instance Arrow (Thrist (->)) where
  arr f = Cons f Nil
  first Nil = Nil
  first (Cons f _) = Cons (f *** Control.Category.id) undefined

{-
class Category cat where
  id :: cat a a
  (.) :: cat b c -> cat a b -> cat a c
  (<<<) :: Category cat => cat b c -> cat a b -> cat a c
  (>>>) :: Category cat => cat a b -> cat b c -> cat a c
-}

instance Category (Thrist (~>)) where
  id = Nil
  b . a = appendThrist a b
  --  below methods are defaulted:
  --
  ---  b <<< a = appendThrist a b
  ---  a >>> b = appendThrist a b