HList and TypeEq

gistfile1.hs

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ScopedTypeVariables, UndecidableInstances, OverlappingInstances #-}

module OptTest () where


data HTrue
data HFalse
class HBool b where hBool :: b -> Bool
instance HBool HTrue where hBool _ = True
instance HBool HFalse where hBool _ = False


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

class TypeEq a b flag | a b -> flag where typeEq :: flag
instance TypeEq x x HTrue where typeEq = undefined
instance (TypeCast HFalse flag) => TypeEq x y flag where typeEq = undefined

data Proxy e

proxy :: Proxy e
proxy = undefined

toProxy :: e -> Proxy e
toProxy _ = undefined

-- example from AdvancedOverlap
class ShowPred a flag | a -> flag
instance ShowPred Int HTrue
instance ShowPred Integer HTrue
instance ShowPred String HTrue
instance TypeCast flag HFalse => ShowPred a flag
class Print a where
	print2 :: a -> String
instance (ShowPred a flag, Print' flag a) => Print a where
    print2 = print' (undefined::flag)
class Print' flag a where 
	print' :: flag -> a -> String
instance Show a => Print' HTrue a where
	print' _ x = show x
instance Print' HFalse a where
	print' _ x = "No show method"


-- basic impl of HList
class HList l

data HNil = HNil deriving (Eq,Show)
data HCons e l = HCons e l deriving (Eq,Show)
instance HList HNil
instance HList l => HList (HCons e l)
(.*.) :: (HList l) => e -> l -> HCons e l
(.*.) = HCons
infixr 1 .*.


-- Only retain elements in the list that have a ShowPred instance defined
class (HList l, HList l') => HShowables l l' | l -> l' where
	hShowables :: l -> l'
instance (ShowPred e flag, HShowablesCase flag e l l', HList l, HList l') => HShowables (HCons e l) l' where
	hShowables (HCons e l) = hShowablesCase (undefined::flag) e l
instance HShowables HNil HNil where
	hShowables = id

class HShowablesCase b e l l' | b e l -> l' where
	hShowablesCase :: b -> e -> l -> l'
instance (HList l, HShowables l l') => HShowablesCase HTrue e l (HCons e l') where
	hShowablesCase _ e l = HCons e (hShowables l)
instance (HShowables l l') => HShowablesCase HFalse e l l' where
	hShowablesCase _ _ l = hShowables l




-- Only retain elements that have the same type as the first element
class (HList l, HList l') => HUnify l l' | l -> l' where
	hUnify :: l -> l'
instance HUnify HNil HNil where hUnify = id
instance HUnify (HCons e HNil) (HCons e HNil) where hUnify = id
instance (HList l, HList l', HUnifyCase flag e e' l l', TypeEq e e' flag) =>
		HUnify (HCons e (HCons e' l)) l' where
	hUnify (HCons e (HCons e' l)) = hUnifyCase (undefined::flag) e e' l

class HUnifyCase b e e' l l' | b e e' l -> l' where
	hUnifyCase :: b -> e -> e' -> l -> l'
instance HUnify (HCons e' l) (HCons e' l') => HUnifyCase HTrue e e' l (HCons e (HCons e' l')) where
	hUnifyCase _ e e' l = HCons e $ hUnify $ HCons e' l
instance HUnify (HCons e l) l' => HUnifyCase HFalse e e' l l' where
	hUnifyCase _ e _ l = hUnify $ HCons e l



-- Sum up all summable things
class Summable a b c x | a b -> c x where sumUp :: a -> b -> c
instance Summable Int Int Int IsSummable where sumUp = (+)
instance Summable Integer Integer Integer IsSummable where sumUp = (+)
instance Summable [a] [a] [a] IsSummable where sumUp = (++)
instance TypeCast summer NotSummable => Summable x y z summer where sumUp = undefined

data IsSummable
data NotSummable


class (HList l, HList l') => HSumUp l l' | l -> l' where hSumUp :: l -> l'
instance HSumUp HNil HNil where hSumUp = id
instance HSumUp (HCons e HNil) (HCons e HNil) where hSumUp = id
instance (HList l, HList l', HSumUpCase flag e e' l l', Summable e e' r flag) =>
		HSumUp (HCons e (HCons e' l)) l' where
	hSumUp (HCons e (HCons e' l)) = hSumUpCase (undefined::flag) e e' l

class HSumUpCase s e e' l l' | s e e' l -> l' where
	hSumUpCase :: s -> e -> e' -> l -> l'
instance (Summable e e' r IsSummable, HSumUp (HCons r l) l') => HSumUpCase IsSummable e e' l l' where
	hSumUpCase _ e e' l = hSumUp $ HCons (sumUp e e') l
instance (HList l, HSumUp (HCons e' l) l') => HSumUpCase NotSummable e e' l (HCons e l') where
	hSumUpCase _ e e' l = HCons e $ hSumUp $ HCons e' l