module Data.Shapely.Normal.Massageable
where
import Data.Shapely.Classes
import Data.Shapely.Normal.Classes
import Data.Shapely.Normal.TypeIndexed hiding(viewType)
import Data.Shapely.Bool
import Data.Shapely.Category(swapFront)
import Data.Shapely.Utilities
import Control.Arrow((***))
import Data.Proxy
--TODO:
class TypeIndexPred a l l' (b::Bool) | a l -> l', a l l' -> b where
viewType :: l -> (a,l')
viewType = error "viewType: Method called in False predicate instance"
instance (HasAny a l lHasA, Not lHasA ~ b)=> TypeIndexPred a (a,l) l b where
viewType = id
instance (TypeIndexPred a l l' b, xl' ~ (x,l'))=> TypeIndexPred a (x,l) xl' b where
viewType = swapFront . fmap viewType
data Void
instance (False ~ false, Void ~ void)=> TypeIndexPred a () void false
instance HasAny a Void False
class IsAllUnique x (b::Bool) | x -> b
instance (true ~ True)=> IsAllUnique () true
instance (IsAllUnique xs tailUnique
, HasAny x xs xInXs
, And tailUnique (Not xInXs) ~ b
)=> IsAllUnique (x,xs) b
data FLAT = FLAT
class MassageableNormal x y where
massageNormal :: x -> y
instance (MassageableNormalRec FLAT FLAT x y)=> MassageableNormal x y where
massageNormal = massageNormalRec (Proxy :: Proxy FLAT, Proxy :: Proxy FLAT)
class Massageable a b where
massage :: a -> b
instance (Shapely a, Shapely b
, MassageableNormalRec a b (Normal a) (Normal b)
)=> Massageable a b where
massage a = let b = massageNormalRec (return a, return b) $$ a
in b
class MassageableNormalRec pa pb na nb where
massageNormalRec :: (Proxy pa, Proxy pb)
-> na -> nb
instance (MassageableNormalRec a b s t, MassageableNormalRec a b ss t)=> MassageableNormalRec a b (Either s ss) t where
massageNormalRec ab = either (massageNormalRec ab) (massageNormalRec ab)
instance ( IsAllUnique (x,xs) isTIPStyle
, ProductToProductPred isTIPStyle a b (x,xs) xss isHeadMassageable
, ProductToSum isHeadMassageable a b (x, xs) (Either xss yss)
)=> MassageableNormalRec a b (x,xs) (Either xss yss) where
massageNormalRec = massageProdCoprod (Proxy::Proxy isHeadMassageable)
instance ( IsAllUnique () isTIPStyle
, ProductToProductPred isTIPStyle a b () xss isHeadMassageable
, ProductToSum isHeadMassageable a b () (Either xss yss)
)=> MassageableNormalRec a b () (Either xss yss) where
massageNormalRec = massageProdCoprod (Proxy::Proxy isHeadMassageable)
instance ( Product xs, Product ys
, IsAllUnique xs isTIPStyle
, ProductToProductPred isTIPStyle a b xs ys True
)=> MassageableNormalRec a b xs ys where
massageNormalRec ab = massageProdProd (Proxy::Proxy isTIPStyle, ab)
alsoMassage :: (Shapely pa, Shapely pb
)=> MassageableNormalRec pa pb (Normal pa) (Normal pb)=> (Proxy pa,Proxy pb) -> pa -> pb
alsoMassage ab a = massageNormalRec ab $$ a
class ProductToSum (isHeadMassageable::Bool) pa pb s t where
massageProdCoprod :: Proxy isHeadMassageable -> (Proxy pa, Proxy pb) -> s -> t
instance ( IsAllUnique xss isTIPStyle
, ProductToProductPred isTIPStyle pa pb xss xs True
, AnyMassageable pa pb xss ys False
)=> ProductToSum True pa pb xss (Either xs ys) where
massageProdCoprod _ ab = Left . massageProdProd (Proxy :: Proxy isTIPStyle,ab)
instance (MassageableNormalRec pa pb yss ys)=> ProductToSum False pa pb yss (Either xs ys) where
massageProdCoprod _ ab = Right . massageNormalRec ab
class AnyMassageable pa pb xss yss (b :: Bool) | pa pb xss yss -> b
instance ( IsAllUnique xss isTIPStyle
, ProductToProductPred isTIPStyle pa pb xss xs headMassageable
, AnyMassageable pa pb xss ys anyTailMassageable
, Or headMassageable anyTailMassageable ~ b
)=> AnyMassageable pa pb xss (Either xs ys) b
instance ( IsAllUnique xss isTIPStyle
, ProductToProductPred isTIPStyle pa pb xss xs b
)=> AnyMassageable pa pb xss xs b
class ProductToProductPred (isTIPStyle::Bool) pa pb s t (b::Bool) | isTIPStyle pa pb s t -> b where
massageProdProd :: (Proxy isTIPStyle, (Proxy pa, Proxy pb)) -> s -> t
massageProdProd = error "massageProdProd: Method called in False predicate instance"
instance ProductToProductPred either pa pb () () True where
massageProdProd _ = id
instance ( ProductToProductPred True pa pb xxs' ys tailsTIPMassageable
, TypeIndexPred y (x,xs) xxs' xxsHasY
, And tailsTIPMassageable xxsHasY ~ b
)=> ProductToProductPred True pa pb (x,xs) (y,ys) b where
massageProdProd ps = fmap (massageProdProd ps) . viewType
instance ( ProductToProductPred True pa pb xxs' ys tailsTIPMassageable
, TypeIndexPred pa (x,xs) xxs' xxsHasRecursiveA
, And tailsTIPMassageable xxsHasRecursiveA ~ b
, MassageableNormalRec pa pb (Normal pa) (Normal pb)
, Shapely pa, Shapely pb
)=> ProductToProductPred True pa pb (x,xs) (pb, ys) b where
massageProdProd ps = (alsoMassage (snd ps) *** massageProdProd ps) . viewType
instance ( ProductToProductPred False pa pb ys ys' b
, MassageableNormalRec pa pb (Normal pa) (Normal pb)
, Shapely pa, Shapely pb
)=> ProductToProductPred False pa pb (pa, ys) (pb, ys') b where
massageProdProd ps = alsoMassage (snd ps) *** massageProdProd ps
instance (ProductToProductPred False pa pb ys ys' b
)=> ProductToProductPred False pa pb (x,ys) (x,ys') b where
massageProdProd = fmap . massageProdProd
instance (ProductToProductPred False x x ys ys' b
)=> ProductToProductPred False x x (x,ys) (x,ys') b where
massageProdProd = fmap . massageProdProd
instance (False ~ false)=> ProductToProductPred either pa pb s t false