{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Dep.Dynamic
(
DynamicEnv
, insertDep
, deleteDep
, DepNotFound (..)
, SomeDepRep (..)
, depRep
, mempty
, Bare
, fromBare
, toBare
)
where
import Dep.Env
import Dep.Has
import Control.Applicative
import Control.Exception
import Data.Coerce
import Data.Function (fix)
import Data.Functor (($>), (<&>))
import Data.HashSet (HashSet)
import Data.HashSet qualified as HashSet
import Data.Functor.Compose
import Data.Functor.Constant
import Data.Functor.Identity
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as H
import Data.Kind
import Data.Proxy
import Data.String
import Data.Dynamic
import Data.Type.Equality (type (==))
import Data.Typeable
import GHC.Generics qualified as G
import GHC.Records
import GHC.TypeLits
import Type.Reflection qualified as R
import Data.Hashable
import Algebra.Graph
import Dep.Dynamic.Internal
import Data.Monoid
newtype DynamicEnv (h :: Type -> Type) (m :: Type -> Type)
= DynamicEnv (HashMap SomeDepRep Dynamic)
deriving newtype instance Semigroup (DynamicEnv h m)
deriving newtype instance Monoid (DynamicEnv h m)
insertDep ::
forall r_ h m.
(Typeable r_, Typeable h, Typeable m) =>
h (r_ m) ->
DynamicEnv h m ->
DynamicEnv h m
insertDep :: forall (r_ :: (* -> *) -> *) (h :: * -> *) (m :: * -> *).
(Typeable r_, Typeable h, Typeable m) =>
h (r_ m) -> DynamicEnv h m -> DynamicEnv h m
insertDep h (r_ m)
component (DynamicEnv HashMap SomeDepRep Dynamic
dict) =
let key :: SomeDepRep
key = forall (a :: (* -> *) -> *). TypeRep a -> SomeDepRep
SomeDepRep (forall {k} (a :: k). Typeable a => TypeRep a
R.typeRep @r_)
in forall (h :: * -> *) (m :: * -> *).
HashMap SomeDepRep Dynamic -> DynamicEnv h m
DynamicEnv (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert SomeDepRep
key (forall a. Typeable a => a -> Dynamic
toDyn h (r_ m)
component) HashMap SomeDepRep Dynamic
dict)
deleteDep ::
forall (r_ :: (Type -> Type) -> Type) h m.
Typeable r_ =>
DynamicEnv h m ->
DynamicEnv h m
deleteDep :: forall (r_ :: (* -> *) -> *) (h :: * -> *) (m :: * -> *).
Typeable r_ =>
DynamicEnv h m -> DynamicEnv h m
deleteDep (DynamicEnv HashMap SomeDepRep Dynamic
dict) =
let key :: SomeDepRep
key = forall (a :: (* -> *) -> *). TypeRep a -> SomeDepRep
SomeDepRep (forall {k} (a :: k). Typeable a => TypeRep a
R.typeRep @r_)
in forall (h :: * -> *) (m :: * -> *).
HashMap SomeDepRep Dynamic -> DynamicEnv h m
DynamicEnv (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete SomeDepRep
key HashMap SomeDepRep Dynamic
dict)
instance (Typeable r_, Typeable m) => Has r_ m (DynamicEnv Identity m) where
dep :: DynamicEnv Identity m -> r_ m
dep (DynamicEnv HashMap SomeDepRep Dynamic
dict) =
case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (forall (a :: (* -> *) -> *). TypeRep a -> SomeDepRep
SomeDepRep (forall {k} (a :: k). Typeable a => TypeRep a
R.typeRep @r_)) HashMap SomeDepRep Dynamic
dict of
Maybe Dynamic
Nothing ->
forall a e. Exception e => e -> a
throw (TypeRep -> DepNotFound
DepNotFound (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @(r_ m))))
Just (Dynamic
d :: Dynamic) ->
case forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(Identity (r_ m)) Dynamic
d of
Maybe (Identity (r_ m))
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible failure converting dep."
Just (Identity r_ m
component) -> r_ m
component
newtype DepNotFound = DepNotFound TypeRep deriving (Int -> DepNotFound -> ShowS
[DepNotFound] -> ShowS
DepNotFound -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DepNotFound] -> ShowS
$cshowList :: [DepNotFound] -> ShowS
show :: DepNotFound -> [Char]
$cshow :: DepNotFound -> [Char]
showsPrec :: Int -> DepNotFound -> ShowS
$cshowsPrec :: Int -> DepNotFound -> ShowS
Show)
instance Exception DepNotFound
instance Phased DynamicEnv where
traverseH
:: forall (h :: Type -> Type) (f :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type).
( Applicative f
, Typeable f
, Typeable g
, Typeable h
, Typeable m
)
=> (forall x . Typeable x => h x -> f (g x))
-> DynamicEnv h m
-> f (DynamicEnv g m)
traverseH :: forall (h :: * -> *) (f :: * -> *) (g :: * -> *) (m :: * -> *).
(Applicative f, Typeable f, Typeable g, Typeable h, Typeable m) =>
(forall x. Typeable x => h x -> f (g x))
-> DynamicEnv h m -> f (DynamicEnv g m)
traverseH forall x. Typeable x => h x -> f (g x)
trans (DynamicEnv HashMap SomeDepRep Dynamic
dict) = forall (h :: * -> *) (m :: * -> *).
HashMap SomeDepRep Dynamic -> DynamicEnv h m
DynamicEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
H.traverseWithKey SomeDepRep -> Dynamic -> f Dynamic
dynTrans HashMap SomeDepRep Dynamic
dict
where
withComponent :: forall (r_ :: (Type -> Type) -> Type) . Typeable r_
=> R.TypeRep r_
-> Dynamic
-> f Dynamic
withComponent :: forall (r_ :: (* -> *) -> *).
Typeable r_ =>
TypeRep r_ -> Dynamic -> f Dynamic
withComponent TypeRep r_
_ Dynamic
d =
case forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(h (r_ m)) Dynamic
d of
Maybe (h (r_ m))
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible failure converting dep."
Just h (r_ m)
hcomponent -> forall a. Typeable a => a -> Dynamic
toDyn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x. Typeable x => h x -> f (g x)
trans h (r_ m)
hcomponent
dynTrans :: SomeDepRep -> Dynamic -> f Dynamic
dynTrans SomeDepRep
k Dynamic
d = case SomeDepRep
k of
SomeDepRep TypeRep a
tr ->
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
R.withTypeable TypeRep a
tr (forall (r_ :: (* -> *) -> *).
Typeable r_ =>
TypeRep r_ -> Dynamic -> f Dynamic
withComponent TypeRep a
tr Dynamic
d)
liftA2H
:: forall (a :: Type -> Type) (f :: Type -> Type) (f' :: Type -> Type) (m :: Type -> Type) .
( Typeable a
, Typeable f
, Typeable f'
, Typeable m
) =>
(forall x. Typeable x => a x -> f x -> f' x) ->
DynamicEnv a m ->
DynamicEnv f m ->
DynamicEnv f' m
liftA2H :: forall (a :: * -> *) (f :: * -> *) (f' :: * -> *) (m :: * -> *).
(Typeable a, Typeable f, Typeable f', Typeable m) =>
(forall x. Typeable x => a x -> f x -> f' x)
-> DynamicEnv a m -> DynamicEnv f m -> DynamicEnv f' m
liftA2H forall x. Typeable x => a x -> f x -> f' x
trans (DynamicEnv HashMap SomeDepRep Dynamic
dicta) (DynamicEnv HashMap SomeDepRep Dynamic
dictb) = forall (h :: * -> *) (m :: * -> *).
HashMap SomeDepRep Dynamic -> DynamicEnv h m
DynamicEnv (forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
H.mapWithKey SomeDepRep -> (Dynamic, Dynamic) -> Dynamic
dynTrans (forall k v1 v2 v3.
(Eq k, Hashable k) =>
(v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3
H.intersectionWith (,) HashMap SomeDepRep Dynamic
dicta HashMap SomeDepRep Dynamic
dictb))
where
withComponent :: forall (r_ :: (Type -> Type) -> Type) . Typeable r_
=> R.TypeRep r_
-> (Dynamic, Dynamic)
-> Dynamic
withComponent :: forall (r_ :: (* -> *) -> *).
Typeable r_ =>
TypeRep r_ -> (Dynamic, Dynamic) -> Dynamic
withComponent TypeRep r_
_ (Dynamic
da, Dynamic
df) =
case (forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(a (r_ m)) Dynamic
da, forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(f (r_ m)) Dynamic
df) of
(Maybe (a (r_ m))
Nothing, Maybe (f (r_ m))
_) -> forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible failure converting left dep."
(Maybe (a (r_ m))
_, Maybe (f (r_ m))
Nothing) -> forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible failure converting right dep."
(Just a (r_ m)
acomponent, Just f (r_ m)
fcomponent) -> forall a. Typeable a => a -> Dynamic
toDyn (forall x. Typeable x => a x -> f x -> f' x
trans a (r_ m)
acomponent f (r_ m)
fcomponent)
dynTrans :: SomeDepRep -> (Dynamic, Dynamic) -> Dynamic
dynTrans SomeDepRep
k (Dynamic, Dynamic)
dpair = case SomeDepRep
k of
SomeDepRep TypeRep a
tr ->
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
R.withTypeable TypeRep a
tr (forall (r_ :: (* -> *) -> *).
Typeable r_ =>
TypeRep r_ -> (Dynamic, Dynamic) -> Dynamic
withComponent TypeRep a
tr (Dynamic, Dynamic)
dpair)