gistfile1.hsc

{-# LANGUAGE UndecidableInstances, OverlappingInstances, MultiParamTypeClasses, FunctionalDependencies, TypeOperators
           , TypeFamilies, EmptyDataDecls, FlexibleInstances, ScopedTypeVariables, KindSignatures, GADTs #-}

module Uncurry where

data Fun :: * -> * -> * -> * where
  Done :: Fun () r r
  Moar :: Fun xs f r -> Fun (x,xs) (x -> f) r

class Uncurry args func result | func -> args, func -> result, args result -> func where
    reify :: Fun args func result

class Uncurry' flag args func result | flag func -> args, flag func -> result, args result -> func where
    reify' :: flag -> Fun args func result

data HTrue;
data HFalse;

instance Uncurry' HFalse () a a where
    reify' _ = Done

instance Uncurry rest f r => Uncurry' HTrue (a,rest) (a -> f) r where
    reify' _ = Moar reify

class IsFunction t b | t -> b
instance (b ~ HTrue) => IsFunction (a -> c) b
instance (b ~ HFalse) => IsFunction a b

instance (IsFunction func b,Uncurry' b args func result) => Uncurry args func result where
    reify = reify' (undefined :: b)

data Homo :: * -> * -> * where
  Ok :: Homo a ()
  Check :: Homo a xs -> Homo a (a,xs)

class IsHomo a args where
  isHomo :: Homo a args
instance IsHomo a () where
  isHomo = Ok
instance (a ~ b, IsHomo a xs) => IsHomo a (b,xs) where
  isHomo = Check isHomo

fromList :: (Uncurry args func result, IsHomo a args) => func -> [a] -> result
fromList = fromList' reify isHomo
fromList' :: Fun args func result -> Homo a args -> func -> [a] -> result
fromList' Done _ r _ = r
fromList' (Moar fun) (Check hom) f (x:xs) = fromList' fun hom (f x) xs

uncurry' :: Fun args func result -> func -> args -> result
uncurry' Done r () = r
uncurry' (Moar fun) f (x,xs) = uncurry' fun (f x) xs

curry' :: Fun args func result -> (args -> result) -> func                                                                  
curry' Done f = f ()
curry' (Moar fun) f = \x -> curry' fun (\xs -> f (x,xs))

foo :: (Uncurry args func result, IsHomo a args, Num a) => func -> a -> result
foo f x = fromList f (iterate (+1) x)

test x y z = z :: Int
{-
*Uncurry> foo test 0
2
-}