module Data.Shapely.Normal.TypeIndexed (
HasAny
, viewType , viewTypeOf
, HavingType(..)
, DeleteAllType(..)
, NubType(..)
) where
import Data.Shapely.Category
import Data.Shapely.Normal.Classes
class HasAny a l (b::Bool) | a l -> b
instance HasAny a (a,l) True
instance (HasAny a l b)=> HasAny a (x,l) b
instance HasAny a () False
instance HasAny p (Either p ps) True
instance (HasAny a (Tail (Either x l)) b)=> HasAny a (Either x l) b
instance HasAny p (Only p) True
instance (false ~ False)=> HasAny p (Only x) false
class NubType l l' | l -> l' where
nubType :: l -> l'
instance (() ~ l')=> NubType () l' where
nubType () = ()
instance (DeleteAllType x xys ys, NubType ys ys', x_ys' ~ (x,ys'))=> NubType (x,xys) x_ys' where
nubType (x,xys) = (x, nubType (xys `deleteAllTypeOf` x))
class DeleteAllType a l l' | a l -> l' where
deleteAllTypeOf :: l -> a -> l'
instance (u ~ ())=> DeleteAllType a () u where
deleteAllTypeOf = const
instance (DeleteAllType a l l')=> DeleteAllType a (a,l) l' where
deleteAllTypeOf = deleteAllTypeOf . snd
instance (DeleteAllType a l l', (x,l') ~ x_l')=> DeleteAllType a (x,l) x_l' where
deleteAllTypeOf l a = fmap (`deleteAllTypeOf` a) l
viewType :: (HasAny a (Tail (NormalConstr l a l')) False, HavingType a l l')=> l -> NormalConstr l a l'
viewType = viewFirstType
viewTypeOf :: (HasAny a (Tail (NormalConstr l a l')) False, HavingType a l l')=> l -> a -> NormalConstr l a l'
viewTypeOf = const . viewType
class HavingType a l l' | a l -> l' where
viewFirstType :: l -> NormalConstr l a l'
viewFirstTypeOf :: l -> a -> NormalConstr l a l'
viewFirstTypeOf = const . viewFirstType
instance (Product l)=> HavingType a (a,l) l where
viewFirstType = id
instance (Product l, HavingType a l l', (x,l') ~ xl')=> HavingType a (x,l) xl' where
viewFirstType = swapFront . fmap viewFirstType
instance (Sum (Either () ps))=> HavingType () (Either () ps) ps where
viewFirstType = id
instance (Sum (Either (x,y) ps))=> HavingType (x,y) (Either (x,y) ps) ps where
viewFirstType = id
instance (Sum (Either () ()))=> HavingType () (Either () ()) () where
viewFirstType = id
instance (Sum (Either (x,y) (x,y)))=> HavingType (x,y) (Either (x,y) (x,y)) (x,y) where
viewFirstType = id
instance (x' ~ x, Product p)=> HavingType p (Either x p) x' where
viewFirstType = swap
instance (HavingType a y l', Either x l' ~ xl', Sum y)=> HavingType a (Either x y) xl' where
viewFirstType = swapFront . fmap viewFirstType