{-# LANGUAGE GADTs, RankNTypes, KindSignatures, FlexibleInstances, TypeOperators #-} module Data.Thrist ( -- * Types: Thrist (..) , Flipped (..) -- * Fold and map functions: , mapThrist , foldrThrist , foldlThrist , foldr1Thrist , foldl1Thrist -- ** Monadic functions: , mapMThrist , foldMThrist -- * Other list-like functions: , appendThrist , nullThrist ) where import Prelude hiding ((.), id) import Control.Category import Data.Monoid import Control.Arrow import Control.Monad -- | A type-threaded list of binary polymorphic types. 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 -- | A newtype wrapper, defined for convenience, that "swaps" the two type -- variables of a binary type. Can be used to reverse a Thrist using -- `foldlThrist`. See examples. newtype Flipped m a b = Flipped { unflip :: m b a } -- | Equivalent to `foldr` for thrists. Takes a combining function, a value to -- replace Nil, and a thrist, returning some new binary type. 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) -- | Equivalent to (++) for thrists. appendThrist :: Thrist (~>) a b -> Thrist (~>) b c -> Thrist (~>) a c appendThrist = flip (foldrThrist Cons) -- | Equivalent to `map` for thrists. Takes a function from one binary type to -- another and applies it to each thrist element. For example this could -- convert a thrist of (a,b) into a thrist of Either a b: mapThrist :: (forall i j . (i +> j) -> (i ~> j)) -> Thrist (+>) a b -> Thrist (~>) a b mapThrist f = foldrThrist (Cons . f) Nil -- | Equivalent to `foldl` for `Thrist`s. 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 -- | Equivalent to `foldl1` for `Thrist`s. 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" -- | Equivalent to `foldr1` for `Thrist`s. 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" -- | Equivalent to `mapM` on `Thrist`s. 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) -- | Equivalent to `foldM` on `Thrist`s. 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 -- | Returns `True` when the Thrist is `Nil`. nullThrist :: Thrist (~>) a b -> Bool nullThrist Nil = True nullThrist _ = False