{-# 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