module Data.Type.Monomorphic ( (:.:), Monomorphic (..), Monomorphicable(..)
, demote', demoteComposed, monomorphicCompose
, withPolymorhic, liftPoly, viaPoly, Compose(..)
) where
import Control.Arrow
import Data.Functor.Compose
type (:.:) f g = Compose f g
data Monomorphic k = forall a. Monomorphic (k a)
class Monomorphicable k where
type MonomorphicRep k :: *
promote :: MonomorphicRep k -> Monomorphic k
demote :: Monomorphic k -> MonomorphicRep k
demote' :: Monomorphicable k => k a -> MonomorphicRep k
demote' = demote . Monomorphic
demoteComposed :: Monomorphicable (f :.: g) => f (g a) -> MonomorphicRep (f :.: g)
demoteComposed = demote . Monomorphic . Compose
monomorphicCompose :: f (g a) -> Monomorphic (f :.: g)
monomorphicCompose = Monomorphic . Compose
withPolymorhic :: Monomorphicable k
=> MonomorphicRep k -> (forall a. k a -> b) -> b
withPolymorhic k trans =
case promote k of
Monomorphic a -> trans a
liftPoly :: Monomorphicable k
=> (forall a. k a -> b) -> MonomorphicRep k -> b
liftPoly = flip withPolymorhic
viaPoly :: (Monomorphicable k, Monomorphicable k')
=> (forall x y. k x -> k' y) -> MonomorphicRep k -> MonomorphicRep k'
viaPoly f a = demote $ Monomorphic $ liftPoly f a
instance (Show (MonomorphicRep k), Monomorphicable k) => Show (Monomorphic k) where
showsPrec d x = showString "Polymorphic " . showsPrec (d + 1) (demote x)
instance (Read (MonomorphicRep k), Monomorphicable k) => Read (Monomorphic k) where
readsPrec i = map (first promote) . readsPrec i