[Haskell-cafe] A type class puzzle

[Yitzchak Gale]

On Tue, Oct 31, 2006 I wrote:
> Consider the following sequence of functions
> that replace a single element in an n-dimensional
> list:
>
> replace0 :: a -> a -> a
> replace1 :: Int -> a -> [a] -> [a]
> replace2 :: Int -> Int -> a -> [[a]] -> [[a]]
>
> Generalize this using type classes.

Thanks to everyone for the refernces about the
variadic composition operator.

However, that technique only provides a variable
number of arguments at the end of the argument
list (like in C, etc.). The puzzle as stated requires
them at the beginning.

Below is a proposed full solution. Unfortunately,
it compiles neither in Hugs nor in GHC. But I don't
understand why not.

GHC says:

    Functional dependencies conflict between instance declarations:
      instance Replace Zero a a (a -> a -> a)
      instance (...) => Replace (Succ n) a [l] f'

Not true. The type constraints on the second instance
prevent any overlap.

Hugs says:

ERROR "./Replace.hs":63 - Instance is more general than a dependency allows
*** Instance         : Replace (Succ a) b [c] d
*** For class        : Replace a b c d
*** Under dependency : a b -> c d

Not true. The type constraints limit the scope to within the fundeps.

Here is the program:

> {-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}

We will need ordinals to count the number of initial function arguments.

> data Zero = Zero
> data Succ o = Succ o

> class Ordinal o where
>   ordinal :: o

> instance Ordinal Zero where
>   ordinal = Zero

> instance Ordinal n => Ordinal (Succ n) where
>   ordinal = Succ ordinal

Args is a model for functions with a variable number of
initial arguments of homogeneous type.

> data Args a b = Args0 b | ArgsN (a -> Args a b)

> instance Functor (Args a) where
>   fmap f (Args0 x) = Args0 $ f x
>   fmap f (ArgsN g) = ArgsN $ fmap f . g

constN is a simple example of an Args. It models a variation
on const (well, flip const, actually) that ignores a variable
number of initial arguments.

> class Ordinal n => ConstN n where
>   constN :: n -> b -> Args a b

> instance ConstN Zero where
>   constN _ = Args0

> instance ConstN n => ConstN (Succ n) where
>   constN (Succ o) = ArgsN . const . constN o

We can convert any Args into the actual function that it represents.
(The inverse is also possible, but we do not need that here.)

> class Ordinal n => ArgsToFunc n a b f where
>   argsToFunc :: n -> Args a b -> f

> instance ArgsToFunc Zero a b b where
>   argsToFunc _ (Args0 b) = b

> instance ArgsToFunc n a b f => ArgsToFunc (Succ n) a b (a -> f) where
>   argsToFunc (Succ o) (ArgsN g) = argsToFunc o . g

When the return type is itself a function, we will need to flip
arguments of the internal function out of the Args.

> flipOutArgs :: Args a (b -> c) -> b -> Args a c
> flipOutArgs (Args0 f) = Args0 . f
> flipOutArgs (ArgsN f) x = ArgsN $ flip flipOutArgs x . f

flipInArgs is the inverse of flipOutArgs. It requires an ordinal, because
we need to know how far in to flip the argument.

> class Ordinal n => FlipInArgs n where
>   flipInArgs :: n -> (b -> Args a c) -> Args a (b -> c)

> instance FlipInArgs Zero where
>   flipInArgs _ f = Args0 $ argsToFunc Zero . f

> instance FlipInArgs n => FlipInArgs (Succ n) where
>   flipInArgs (Succ o) f = ArgsN $ flipInArgs o . g
>     where g x y = let ArgsN h = f y in h x

Now we are ready to construct replace.

> class ArgsToFunc n Int (a -> l -> l) f =>
>       Replace n a l f | n a -> l f, f -> n a l
>   where
>     replaceA :: n -> Args Int a
>     replace :: f

> instance Replace Zero a a (a -> a -> a) where
>   replaceA _ = Args0 const
>   replace = const

> instance (Replace n a l f, FlipInArgs n, ConstN n,
>           ArgsToFunc (Succ n) Int (a -> [l] -> [l]) f') =>
>          Replace (Succ n) a [l] f' where
>   replaceA (Succ o) = ArgsN mkReplace
>     where
>       mkReplace i = flipInArgs o $ flipInArgs o . mkRepl o i
>       mkRepl o i x xs
>        | null t    = constN o h
>        | otherwise = fmap (h ++) $ fmap (: tail t) $
>                      flipOutArgs (flipOutArgs (replaceA o) x) xs
>        where (h, t) = splitAt i xs
>   replace = argsToFunc ordinal $ replaceA ordinal