module Data.Extensible.Dictionary where
import Data.Monoid
import Data.Extensible.Product
import Data.Extensible.Sum
import Data.Extensible.Internal
import Data.Extensible.Internal.Rig
import qualified Data.Binary as B
import Data.Constraint
library :: forall c xs. Forall c xs => Comp Dict c :* xs
library = htabulateFor (Proxy :: Proxy c) $ const (Comp Dict)
instance WrapForall Show h xs => Show (h :* xs) where
showsPrec d = showParen (d > 0)
. (.showString "Nil")
. foldr (.) id
. getMerged
. hfoldMap getConst'
. hzipWith (\(Comp Dict) h -> Const' $ MergeList [showsPrec 0 h . showString " <: "]) (library :: Comp Dict (Instance1 Show h) :* xs)
instance WrapForall Eq h xs => Eq (h :* xs) where
xs == ys = getAll $ hfoldMap (All . getConst')
$ hzipWith3 (\(Comp Dict) x y -> Const' $ x == y) (library :: Comp Dict (Instance1 Eq h) :* xs) xs ys
instance (Eq (h :* xs), WrapForall Ord h xs) => Ord (h :* xs) where
compare xs ys = hfoldMap getConst'
$ hzipWith3 (\(Comp Dict) x y -> Const' $ compare x y) (library :: Comp Dict (Instance1 Ord h) :* xs) xs ys
instance WrapForall Monoid h xs => Monoid (h :* xs) where
mempty = hmap (\(Comp Dict) -> mempty) (library :: Comp Dict (Instance1 Monoid h) :* xs)
mappend xs ys = hzipWith3 (\(Comp Dict) -> mappend) (library :: Comp Dict (Instance1 Monoid h) :* xs) xs ys
instance WrapForall B.Binary h xs => B.Binary (h :* xs) where
get = hgenerateFor (Proxy :: Proxy (Instance1 B.Binary h)) (const B.get)
put = flip appEndo (return ()) . hfoldMap getConst' . hzipWith (\(Comp Dict) x -> Const' $ Endo $ (B.put x >>)) (library :: Comp Dict (Instance1 B.Binary h) :* xs)
instance WrapForall Show h xs => Show (h :| xs) where
showsPrec d (UnionAt pos h) = showParen (d > 10) $ showString "embed "
. views (sectorAt pos) (\(Comp Dict) -> showsPrec 11 h) (library :: Comp Dict (Instance1 Show h) :* xs)
instance WrapForall Eq h xs => Eq (h :| xs) where
UnionAt p g == UnionAt q h = case compareMembership p q of
Left _ -> False
Right Refl -> views (sectorAt p) (\(Comp Dict) -> g == h) (library :: Comp Dict (Instance1 Eq h) :* xs)
instance (Eq (h :| xs), WrapForall Ord h xs) => Ord (h :| xs) where
UnionAt p g `compare` UnionAt q h = case compareMembership p q of
Left x -> x
Right Refl -> views (sectorAt p) (\(Comp Dict) -> compare g h) (library :: Comp Dict (Instance1 Ord h) :* xs)
type WrapForall c h = Forall (Instance1 c h)
class c (h x) => Instance1 c h x
instance c (h x) => Instance1 c h x