ApplyVariant.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Proxy (Proxy(..))
import DBus (IsVariant(..), Variant)

class ApplyVariant (n :: [*]) f r | f -> r, n f -> r where
  applyVariant :: p n -> f -> [Variant] -> Maybe r

-- no need for overlapping with the kind indexing...
--instance TypeCast f r => ApplyVariant '[] f r where
instance f ~ r => ApplyVariant '[] f r where
  --applyVariant _ p [] = Just $ typeCast p
  applyVariant _ p [] = Just p
  applyVariant _ _ _  = Nothing

instance (IsVariant a, ApplyVariant as b r, a ~ a') => ApplyVariant (a' ': as) (a -> b) r where
  applyVariant _ f (x:xs) = (fromVariant x :: Maybe a) >>= \r -> applyVariant (Proxy :: Proxy as) (f r) xs
  applyVariant _ _ []     = Nothing

class ApplyVariant' f r | f -> r where
  applyVariant' :: f -> [Variant] -> Maybe r

instance {-# OVERLAPPABLE #-} f ~ r => ApplyVariant' f r where
  applyVariant' x [] = Just x
  applyVariant' _ _  = Nothing

instance {-# OVERLAPPING #-} (IsVariant a, ApplyVariant' b r) => ApplyVariant' (a -> b) r where
  applyVariant' f (x:xs) = (fromVariant x :: Maybe a) >>= \r -> applyVariant' (f r) xs
  applyVariant' _ []     = Nothing

-- from: http://hackage.haskell.org/package/HList-0.2.3/docs/src/Data-HList-TypeCastGeneric2.html
--class TypeCast   a b   | a -> b, b->a   where typeCast   :: a -> b
--class TypeCast'  t a b | t a -> b, t b -> a where typeCast'  :: t->a->b
--class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b
--instance TypeCast'  () a b => TypeCast a b where typeCast x = typeCast' () x
--instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast''
--instance TypeCast'' () a a where typeCast'' _ x  = x
-- this is really just equivalent to type equalities!