{-# LANGUAGE CPP #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.TypeMap.Internal.Dynamic where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, (<$>))
#endif
import Data.Map (Map)
import Data.Proxy (Proxy(..))
import Data.Typeable
#if MIN_VERSION_base(4,10,0)
import GHC.Exts (Any)
import qualified Type.Reflection as T
#else
import GHC.Prim (Any, Proxy#)
#endif
import Prelude hiding (map)
import Unsafe.Coerce

import qualified Data.Map as Map

-- * Exposed functions

-- | Map from types @t@ of kind @*@ to values of type @Item x t@.
newtype TypeMap x = TypeMap (Map TypeRep Any)

type role TypeMap nominal

-- | An extensible type family mapping types (as keys) to types of values,
-- parameterized by types @x@.
type family Item x t

-- | A constant mapping to type @a@. @'TypeMap' ('OfType' a)@ is the type of
-- maps from types to values of type @a@.
data OfType a
type instance Item (OfType a) t = a

-- | Whether the map is empty.
null :: TypeMap x -> Bool
null :: TypeMap x -> Bool
null (TypeMap Map TypeRep Any
m) = Map TypeRep Any -> Bool
forall k a. Map k a -> Bool
Map.null Map TypeRep Any
m

-- | The number of elements in the map.
size :: TypeMap x -> Int
size :: TypeMap x -> Int
size (TypeMap Map TypeRep Any
m) = Map TypeRep Any -> Int
forall k a. Map k a -> Int
Map.size Map TypeRep Any
m

-- | Empty type map.
empty :: TypeMap x
empty :: TypeMap x
empty = Map TypeRep Any -> TypeMap x
forall x. Map TypeRep Any -> TypeMap x
TypeMap Map TypeRep Any
forall k a. Map k a
Map.empty

-- | Insert an element indexed by type @t@.
insert
  :: forall t x proxy
  .  Typeable t => proxy t -> Item x t -> TypeMap x -> TypeMap x
insert :: proxy t -> Item x t -> TypeMap x -> TypeMap x
insert proxy t
t Item x t
v (TypeMap Map TypeRep Any
m) = Map TypeRep Any -> TypeMap x
forall x. Map TypeRep Any -> TypeMap x
TypeMap (TypeRep -> Any -> Map TypeRep Any -> Map TypeRep Any
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (proxy t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep proxy t
t) (Item x t -> Any
coerce Item x t
v) Map TypeRep Any
m)
  where
    coerce :: Item x t -> Any
    coerce :: Item x t -> Any
coerce = Item x t -> Any
forall a b. a -> b
unsafeCoerce

-- What is a good fixity for (<:)?

-- | Infix version of 'insert' to facilitate a literal-ish syntax:
--
-- @
-- 'empty'
--   '<:' ('Proxy' @k1, v1)
--   '<:' ('Proxy' @k2, v2)
-- @
(<:)
  :: forall t x proxy
  .  Typeable t => TypeMap x -> (proxy t, Item x t) -> TypeMap x
<: :: TypeMap x -> (proxy t, Item x t) -> TypeMap x
(<:) TypeMap x
tm (proxy t
p, Item x t
v) = proxy t -> Item x t -> TypeMap x -> TypeMap x
forall t x (proxy :: * -> *).
Typeable t =>
proxy t -> Item x t -> TypeMap x -> TypeMap x
insert proxy t
p Item x t
v TypeMap x
tm

-- | Update an element indexed by type @t@.
update
  :: forall t x proxy
  .  Typeable t => proxy t -> (Item x t -> Maybe (Item x t)) -> TypeMap x -> TypeMap x
update :: proxy t -> (Item x t -> Maybe (Item x t)) -> TypeMap x -> TypeMap x
update proxy t
t Item x t -> Maybe (Item x t)
f (TypeMap Map TypeRep Any
m) = Map TypeRep Any -> TypeMap x
forall x. Map TypeRep Any -> TypeMap x
TypeMap ((Any -> Maybe Any) -> TypeRep -> Map TypeRep Any -> Map TypeRep Any
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update ((Item x t -> Maybe (Item x t)) -> Any -> Maybe Any
coerce Item x t -> Maybe (Item x t)
f) (proxy t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep proxy t
t) Map TypeRep Any
m)
  where
    coerce :: (Item x t -> Maybe (Item x t)) -> (Any -> Maybe Any)
    coerce :: (Item x t -> Maybe (Item x t)) -> Any -> Maybe Any
coerce = (Item x t -> Maybe (Item x t)) -> Any -> Maybe Any
forall a b. a -> b
unsafeCoerce

-- | Update a (possibly absent) element indexed by type @t@.
alter
  :: forall t x proxy
  .  Typeable t => proxy t -> (Maybe (Item x t) -> Maybe (Item x t)) -> TypeMap x -> TypeMap x
alter :: proxy t
-> (Maybe (Item x t) -> Maybe (Item x t)) -> TypeMap x -> TypeMap x
alter proxy t
t Maybe (Item x t) -> Maybe (Item x t)
f (TypeMap Map TypeRep Any
m) = Map TypeRep Any -> TypeMap x
forall x. Map TypeRep Any -> TypeMap x
TypeMap ((Maybe Any -> Maybe Any)
-> TypeRep -> Map TypeRep Any -> Map TypeRep Any
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter ((Maybe (Item x t) -> Maybe (Item x t)) -> Maybe Any -> Maybe Any
coerce Maybe (Item x t) -> Maybe (Item x t)
f) (proxy t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep proxy t
t) Map TypeRep Any
m)
  where
    coerce :: (Maybe (Item x t) -> Maybe (Item x t)) -> (Maybe Any -> Maybe Any)
    coerce :: (Maybe (Item x t) -> Maybe (Item x t)) -> Maybe Any -> Maybe Any
coerce = (Maybe (Item x t) -> Maybe (Item x t)) -> Maybe Any -> Maybe Any
forall a b. a -> b
unsafeCoerce

-- | Lookup an element indexed by type @t@.
lookup
  :: forall t x proxy
  .  Typeable t => proxy t -> TypeMap x -> Maybe (Item x t)
lookup :: proxy t -> TypeMap x -> Maybe (Item x t)
lookup proxy t
t (TypeMap Map TypeRep Any
m) = Maybe Any -> Maybe (Item x t)
coerce (TypeRep -> Map TypeRep Any -> Maybe Any
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (proxy t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep proxy t
t) Map TypeRep Any
m)
  where
    coerce :: Maybe Any -> Maybe (Item x t)
    coerce :: Maybe Any -> Maybe (Item x t)
coerce = Maybe Any -> Maybe (Item x t)
forall a b. a -> b
unsafeCoerce

-- | Delete a key and its value from the map.
-- Does nothing if the key does not exist.
delete
  :: forall t x proxy
  .  Typeable t => proxy t -> TypeMap x -> TypeMap x
delete :: proxy t -> TypeMap x -> TypeMap x
delete proxy t
t (TypeMap Map TypeRep Any
m) = Map TypeRep Any -> TypeMap x
forall x. Map TypeRep Any -> TypeMap x
TypeMap (TypeRep -> Map TypeRep Any -> Map TypeRep Any
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (proxy t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep proxy t
t) Map TypeRep Any
m)

-- | Left-biased union of two maps; it keeps the first key if duplicates are found.
union
  :: forall x. TypeMap x -> TypeMap x -> TypeMap x
union :: TypeMap x -> TypeMap x -> TypeMap x
union (TypeMap Map TypeRep Any
m) (TypeMap Map TypeRep Any
n) = Map TypeRep Any -> TypeMap x
forall x. Map TypeRep Any -> TypeMap x
TypeMap (Map TypeRep Any -> Map TypeRep Any -> Map TypeRep Any
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map TypeRep Any
m Map TypeRep Any
n)

-- | Difference of two maps; keep elements of the first map which are not in the second.
difference
  :: forall x. TypeMap x -> TypeMap x -> TypeMap x
difference :: TypeMap x -> TypeMap x -> TypeMap x
difference (TypeMap Map TypeRep Any
m) (TypeMap Map TypeRep Any
n) = Map TypeRep Any -> TypeMap x
forall x. Map TypeRep Any -> TypeMap x
TypeMap (Map TypeRep Any -> Map TypeRep Any -> Map TypeRep Any
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map TypeRep Any
m Map TypeRep Any
n)

-- | Intersection of two maps; keep elements of the first map which are also in the second.
intersection
  :: forall x y. TypeMap x -> TypeMap y -> TypeMap x
intersection :: TypeMap x -> TypeMap y -> TypeMap x
intersection (TypeMap Map TypeRep Any
m) (TypeMap Map TypeRep Any
n) = Map TypeRep Any -> TypeMap x
forall x. Map TypeRep Any -> TypeMap x
TypeMap (Map TypeRep Any -> Map TypeRep Any -> Map TypeRep Any
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Map TypeRep Any
m Map TypeRep Any
n)

-- | Map a function on all elements.
map
  :: forall x y
  .  (forall t. Typeable t => Proxy t -> Item x t -> Item y t)
  -> TypeMap x -> TypeMap y
map :: (forall t. Typeable t => Proxy t -> Item x t -> Item y t)
-> TypeMap x -> TypeMap y
map forall t. Typeable t => Proxy t -> Item x t -> Item y t
f (TypeMap Map TypeRep Any
m) = Map TypeRep Any -> TypeMap y
forall x. Map TypeRep Any -> TypeMap x
TypeMap ((TypeRep -> Any -> Any) -> Map TypeRep Any -> Map TypeRep Any
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey TypeRep -> UnTyped (ItemFun x y)
TypeRep -> Any -> Any
f' Map TypeRep Any
m)
  where f' :: TypeRep -> UnTyped (ItemFun x y)
f' = (forall t. Typeable t => Proxy t -> Typed (ItemFun x y) t)
-> Proxy (ItemFun x y) -> TypeRep -> UnTyped (ItemFun x y)
forall x (proxy :: * -> *).
(forall t. Typeable t => Proxy t -> Typed x t)
-> proxy x -> TypeRep -> UnTyped x
withTypeRep forall t. Typeable t => Proxy t -> Typed (ItemFun x y) t
forall t. Typeable t => Proxy t -> Item x t -> Item y t
f (Proxy (ItemFun x y)
forall k (t :: k). Proxy t
Proxy :: Proxy (ItemFun x y))

-- | Reduce a constant type map into a plain list of values.
toList
  :: forall r
  .  TypeMap (OfType r) -> [r]
toList :: TypeMap (OfType r) -> [r]
toList (TypeMap Map TypeRep Any
m) = Any -> r
coerce (Any -> r) -> ((TypeRep, Any) -> Any) -> (TypeRep, Any) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeRep, Any) -> Any
forall a b. (a, b) -> b
snd ((TypeRep, Any) -> r) -> [(TypeRep, Any)] -> [r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TypeRep Any -> [(TypeRep, Any)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TypeRep Any
m
  where
    coerce :: Any -> r
    coerce :: Any -> r
coerce = Any -> r
forall a b. a -> b
unsafeCoerce

-- | Collapse a type map into a plain list of values.
toListMap
  :: forall tm r
  .  (forall t. Proxy t -> Item tm t -> r) -> TypeMap tm -> [r]
toListMap :: (forall t. Proxy t -> Item tm t -> r) -> TypeMap tm -> [r]
toListMap forall t. Proxy t -> Item tm t -> r
f TypeMap tm
tm = TypeMap (OfType r) -> [r]
forall r. TypeMap (OfType r) -> [r]
toList (TypeMap (OfType r) -> [r]) -> TypeMap (OfType r) -> [r]
forall a b. (a -> b) -> a -> b
$ (forall t. Typeable t => Proxy t -> Item tm t -> Item (OfType r) t)
-> TypeMap tm -> TypeMap (OfType r)
forall x y.
(forall t. Typeable t => Proxy t -> Item x t -> Item y t)
-> TypeMap x -> TypeMap y
map forall t. Typeable t => Proxy t -> Item tm t -> Item (OfType r) t
forall t. Proxy t -> Item tm t -> r
f TypeMap tm
tm

-- | Traverse the type map. ('map' with effects.)
traverse
  :: forall f x y
  .  Applicative f
  => (forall t. Typeable t => Proxy t -> Item x t -> f (Item y t))
  -> TypeMap x -> f (TypeMap y)
traverse :: (forall t. Typeable t => Proxy t -> Item x t -> f (Item y t))
-> TypeMap x -> f (TypeMap y)
traverse forall t. Typeable t => Proxy t -> Item x t -> f (Item y t)
f (TypeMap Map TypeRep Any
m) = Map TypeRep Any -> TypeMap y
forall x. Map TypeRep Any -> TypeMap x
TypeMap (Map TypeRep Any -> TypeMap y)
-> f (Map TypeRep Any) -> f (TypeMap y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeRep -> Any -> f Any) -> Map TypeRep Any -> f (Map TypeRep Any)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey TypeRep -> UnTyped (ItemKleisli f x y)
TypeRep -> Any -> f Any
f' Map TypeRep Any
m
  where f' :: TypeRep -> UnTyped (ItemKleisli f x y)
f' = (forall t. Typeable t => Proxy t -> Typed (ItemKleisli f x y) t)
-> Proxy (ItemKleisli f x y)
-> TypeRep
-> UnTyped (ItemKleisli f x y)
forall x (proxy :: * -> *).
(forall t. Typeable t => Proxy t -> Typed x t)
-> proxy x -> TypeRep -> UnTyped x
withTypeRep forall t. Typeable t => Proxy t -> Typed (ItemKleisli f x y) t
forall t. Typeable t => Proxy t -> Item x t -> f (Item y t)
f (Proxy (ItemKleisli f x y)
forall k (t :: k). Proxy t
Proxy :: Proxy (ItemKleisli f x y))

-- * Unsafe internals

type family Typed x t
type family UnTyped x

type instance Typed (OfType a) t = a
type instance UnTyped (OfType a) = a

data ItemFun x y
type instance Typed (ItemFun x y) t = Item x t -> Item y t
type instance UnTyped (ItemFun x y) = Any -> Any

data ItemKleisli (f :: * -> *) x y
type instance Typed (ItemKleisli f x y) t = Item x t -> f (Item y t)
type instance UnTyped (ItemKleisli f x y) = Any -> f Any

withTypeRep
  :: forall x proxy
  .  (forall t. Typeable t => Proxy t -> Typed x t)
  -> proxy x
  -> TypeRep -> UnTyped x
#if MIN_VERSION_base(4,10,0)
withTypeRep :: (forall t. Typeable t => Proxy t -> Typed x t)
-> proxy x -> TypeRep -> UnTyped x
withTypeRep forall t. Typeable t => Proxy t -> Typed x t
f proxy x
_ TypeRep
someRep =
  case TypeRep
someRep of
    T.SomeTypeRep (TypeRep a
rep' :: T.TypeRep t) ->
      -- We still need to unsafely coerce the kind of t to Type
      -- and Typed to UnTyped
      ((TypeRep Any -> Typed x Any) -> TypeRep a -> UnTyped x
forall a b. a -> b
unsafeCoerce
        ((\TypeRep a
rep -> TypeRep a -> (Typeable a => Typed x a) -> Typed x a
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
T.withTypeable TypeRep a
rep (Proxy a -> Typed x a
forall t. Typeable t => Proxy t -> Typed x t
f (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)))
          :: forall a. T.TypeRep a -> Typed x a)
        :: T.TypeRep t -> UnTyped x) TypeRep a
rep'
#else
withTypeRep f _ rep =
  withTypeable (WithTypeable f :: WithTypeable x) (\_ -> rep) Proxy

newtype WithTypeable x
  = WithTypeable (forall t. Typeable t => Proxy t -> Typed x t)

withTypeable :: WithTypeable x -> (Proxy# () -> TypeRep) -> Proxy () -> UnTyped x
withTypeable = unsafeCoerce
#endif