arity.hs

{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}


-- Wrong!

class K k a b c d e | e -> b where (...) :: k a b -> k c d -> k c e

instance {-# OVERLAPS    #-} (a~d2, b~e2, d1~e1)  => K (->) a b c (d1->d2) (e1->e2) where g ... f = \x -> g ... (f x)
instance {-# OVERLAPPING #-} (a~d,  b~e)          => K (->) a b c d e               where g ... f = g . f

plus2 :: Int -> Int
plus2 = succ ... succ

add :: Int -> Int -> Int
add = succ ... (+)


-- Compositional version of C:

-- Non-Recursive instance    (b ~ c, b' ~ c', b'' ~ a, c'' ~ a') => J (a -> a') (b -> (b' -> b'')) (c -> c' -> c'') where f .... g = \x -> f .... (g x)
-- instance                     (c ~ (b -> k), J a b' k                      ) => J a         (b -> b') c         where f .... g = \x -> f .... (g x)
-- instance                  (J a b' c', c ~ (b -> c')         ) => J a         (b -> b') c         where f .... g = \x -> f .... (g x)

infixl 1 ....

class J f g h | f g -> h where (....) :: f -> g -> h
instance                     (J a b' c', b ~ c                 ) => J a         (b -> b') (c -> c') where f .... g = \x -> f .... (g x)
instance {-# INCOHERENT  #-} (           a ~ b', b ~ c, a' ~ c') => J (a -> a') (b -> b') (c -> c') where f .... g = f . g

foo1, foo2, foo3 :: Int -> Int
foo1 = succ
foo2 = succ .... succ
foo3 = succ .... (succ .... succ :: Int -> Int)

-- instance (J a@(String -> String) b'@(Char -> String) c'@(Char->String), b@Int ~ c@Int)
-- => J a@(String -> String) (b@Int -> b'@(Char -> String)) (c@Int -> c'@(Char -> String)) where f .... g = \x -> f .... (g x)

add' :: Int -> Int -> Int
add' = (succ :: Int -> Int) .... ((+) :: Int -> Int -> Int)

tada' :: Int -> Char -> String
tada' = (take 3 :: String -> String) .... (replicate :: Int -> Char -> String)

-- mul' :: Int -> Int -> Int -> Int
-- mul' = succ .... (\x y z -> x + y * z)


-- From https://gist.github.com/i-am-tom/8ce5fd5dbce2a71fe604934d774a08f8:

infixl 1 .~

class C f g h | f g -> h where (.~) :: f -> g -> h

--                                                        (a -> a') (b -> a)  (b -> a')
-- instance                 (a ~ b', b ~ c, a' ~ c') => C (a -> a') (b -> b') (c -> c') where (f .~ g) a = f .~ g a -- Simple version




-- instance                    (k ~ (a -> h), C f g h)  => C f        (a -> g) k where (f .~ g) a = f .~ g a

instance                    (C a b' c', b ~ c) => C a       (b -> b') (c -> c') where (f .~ g) a = f .~ g a
instance {-# InCoHeReNt #-} (a ~ c, b ~ d)     => C (a -> b) c         d        where (.~)       = ($)


foo :: Int
foo = succ .~ 2

tada :: Int -> a -> [a]
tada = take 3 .~ replicate

greet :: String -> String -> String
greet =  (++ "!") .~ \fore sur -> fore <> " " <> sur

mul :: Int -> Int -> Int -> Int
mul = succ .~ (\x y z -> x + y * z)