module Data.Vector.Fixed.Internal.Arity (
Z
, S
, N1
, N2
, N3
, N4
, N5
, N6
, Fn
, Fun(..)
, Arity(..)
, apply
, applyM
) where
import Control.Applicative (Applicative(..))
import Data.Typeable (Typeable)
data Z deriving Typeable
data S n deriving Typeable
type N1 = S Z
type N2 = S N1
type N3 = S N2
type N4 = S N3
type N5 = S N4
type N6 = S N5
type family Fn n a b
type instance Fn Z a b = b
type instance Fn (S n) a b = a -> Fn n a b
newtype Fun n a b = Fun { unFun :: Fn n a b }
instance Arity n => Functor (Fun n a) where
fmap (f :: b -> c) (Fun g0 :: Fun n a b)
= Fun $ accum
(\(T_fmap g) a -> T_fmap (g a))
(\(T_fmap x) -> f x)
(T_fmap g0 :: T_fmap a b n)
instance Arity n => Applicative (Fun n a) where
pure (x :: x) = Fun $ accum (\(T_pure r) (_::a) -> T_pure r)
(\(T_pure r) -> r)
(T_pure x :: T_pure x n)
(Fun f0 :: Fun n a (p -> q)) <*> (Fun g0 :: Fun n a p)
= Fun $ accum (\(T_ap f g) a -> T_ap (f a) (g a))
(\(T_ap f g) -> f g)
(T_ap f0 g0 :: T_ap a (p -> q) p n)
newtype T_fmap a b n = T_fmap (Fn n a b)
data T_pure a n = T_pure a
data T_ap a b c n = T_ap (Fn n a b) (Fn n a c)
class Arity n where
accum :: (forall k. t (S k) -> a -> t k)
-> (t Z -> b)
-> t n
-> Fn n a b
accumM :: Monad m
=> (forall k. t (S k) -> a -> m (t k))
-> (t Z -> m b)
-> m (t n)
-> Fn n a (m b)
applyFun :: (forall k. t (S k) -> (a, t k))
-> t n
-> Fn n a b
-> (b, t Z)
applyFunM :: Monad m
=> (forall k. t (S k) -> m (a, t k))
-> t n
-> Fn n a (m b)
-> m (b, t Z)
arity :: n -> Int
apply :: Arity n
=> (forall k. t (S k) -> (a, t k))
-> t n
-> Fn n a b
-> b
apply step z f = fst $ applyFun step z f
applyM :: (Arity n, Monad m)
=> (forall k. t (S k) -> m (a, t k))
-> t n
-> Fn n a (m b)
-> m b
applyM step z f = do
(r,_) <- applyFunM step z f
return r
instance Arity Z where
accum _ g t = g t
accumM _ g t = g =<< t
applyFun _ t h = (h,t)
applyFunM _ t h = do r <- h
return (r,t)
arity _ = 0
instance Arity n => Arity (S n) where
accum f g t = \a -> accum f g (f t a)
accumM f g t = \a -> accumM f g $ flip f a =<< t
applyFun f t h = case f t of (a,u) -> applyFun f u (h a)
applyFunM f t h = do (a,u) <- f t
applyFunM f u (h a)
arity _ = 1 + arity (undefined :: n)