{-# 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 #-}

-- | This module provies a dynamic version of a dependency injection

-- environment.

--

-- You don't need to declare beforehand what fields exist in the environment,

-- you can simply add them using 'insertDep'.

--

-- I might be useful for quick prototyping, or for when there is a big number

-- of components and putting all of them in a conventional record would slow

-- compilation.

--

-- A 'Dep.Env.fixEnv'-based example:

--

-- >>> :{

--  newtype Foo d = Foo {foo :: String -> d ()} deriving Generic

--  newtype Bar d = Bar {bar :: String -> d ()} deriving Generic

--  makeIOFoo :: MonadIO m => Foo m

--  makeIOFoo = Foo (liftIO . putStrLn)

--  makeBar :: Has Foo m env => env -> Bar m

--  makeBar (asCall -> call) = Bar (call foo)

--  env :: DynamicEnv (Constructor (DynamicEnv Identity IO)) IO

--  env = mempty 

--      & insertDep @Foo (constructor (\_ -> makeIOFoo))

--      & insertDep @Bar (constructor makeBar) 

--  envReady :: DynamicEnv Identity IO

--  envReady = fixEnv env

-- :}

--

-- >>> :{

--  bar (dep envReady) "this is bar"

-- :}

-- this is bar

--

-- The same example using 'Control.Monad.Dep.DepT' and 'Dep.Advice.component':

--

-- >>> :{

--  env' :: DynamicEnv Identity (DepT (DynamicEnv Identity) IO)

--  env' = mempty 

--       & insertDep @Foo (Identity (component (\_ -> makeIOFoo)))

--       & insertDep @Bar (Identity (component makeBar))

-- :}

--

-- >>> :{

--  runFromDep (pure env') bar "this is bar"

-- :}

-- this is bar

--

-- Components are found by type. Use "Dep.Tagged" to disambiguate components of

-- the same type.

--

-- It's not checked at compilation time that the dependencies for all

-- components in the environment are also present in the environment. A

-- `DynamicEnv` exception will be thrown at run time whenever a component tries to

-- find a dependency that doesn't exist: 

--

-- >>> :{

--  badEnv :: DynamicEnv Identity IO

--  badEnv = mempty

-- :}

--

-- >>> :{

--  bar (dep badEnv) "this is bar"

-- :}

-- *** Exception: DepNotFound (Bar IO)

--

-- See `Dep.Checked` and `Dep.SimpleChecked` for safer (but still dynamically typed) approaches.

--

-- See also `Dep.Env.InductiveEnv` for a strongly-typed variant.

module Dep.Dynamic
  (
  -- * A dynamic environment

    DynamicEnv
  , insertDep
  , deleteDep
  , DepNotFound (..)
  , SomeDepRep (..)
  , depRep
  -- * Re-exports

  , 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

-- | A dependency injection environment for components with effects in the monad @m@.

--

-- The components are wrapped in an 'Applicative' phase @h@, which will be

-- 'Data.Functor.Identity.Identity' for \"ready-to-be-used\" environments.

newtype DynamicEnv (h :: Type -> Type) (m :: Type -> Type)
  = DynamicEnv (HashMap SomeDepRep Dynamic)

-- | In '(<>)', the entry for the left map is kept.

deriving newtype instance Semigroup (DynamicEnv h m)

-- | 'mempty' is for creating the empty environment.

deriving newtype instance Monoid (DynamicEnv h m)

-- | Insert a record component wrapped in the environment's phase parameter @h@.

insertDep ::
  forall r_ h m.
  (Typeable r_, Typeable h, Typeable m) =>
  h (r_ m) ->
  DynamicEnv h m ->
  DynamicEnv h m
insertDep :: h (r_ m) -> DynamicEnv h m -> DynamicEnv h m
insertDep h (r_ m)
component (DynamicEnv HashMap SomeDepRep Dynamic
dict) =
  let key :: SomeDepRep
key = TypeRep r_ -> SomeDepRep
forall (a :: (* -> *) -> *). TypeRep a -> SomeDepRep
SomeDepRep (Typeable r_ => TypeRep r_
forall k (a :: k). Typeable a => TypeRep a
R.typeRep @r_)
   in HashMap SomeDepRep Dynamic -> DynamicEnv h m
forall (h :: * -> *) (m :: * -> *).
HashMap SomeDepRep Dynamic -> DynamicEnv h m
DynamicEnv (SomeDepRep
-> Dynamic
-> HashMap SomeDepRep Dynamic
-> HashMap SomeDepRep Dynamic
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert SomeDepRep
key (h (r_ m) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn h (r_ m)
component) HashMap SomeDepRep Dynamic
dict)

-- | The record type to delete is supplied through a type application.

deleteDep ::
  forall (r_ :: (Type -> Type) -> Type) h m.
  Typeable r_ =>
  DynamicEnv h m ->
  DynamicEnv h m
deleteDep :: DynamicEnv h m -> DynamicEnv h m
deleteDep (DynamicEnv HashMap SomeDepRep Dynamic
dict) =
  let key :: SomeDepRep
key = TypeRep r_ -> SomeDepRep
forall (a :: (* -> *) -> *). TypeRep a -> SomeDepRep
SomeDepRep (Typeable r_ => TypeRep r_
forall k (a :: k). Typeable a => TypeRep a
R.typeRep @r_)
   in HashMap SomeDepRep Dynamic -> DynamicEnv h m
forall (h :: * -> *) (m :: * -> *).
HashMap SomeDepRep Dynamic -> DynamicEnv h m
DynamicEnv (SomeDepRep
-> HashMap SomeDepRep Dynamic -> HashMap SomeDepRep Dynamic
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete SomeDepRep
key HashMap SomeDepRep Dynamic
dict)

-- | 'DynamicEnv' has a 'Data.Has.Has' instance for every possible component. If the

-- component is not actually in the environment, 'DepNotFound' is thrown.

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 SomeDepRep -> HashMap SomeDepRep Dynamic -> Maybe Dynamic
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (TypeRep r_ -> SomeDepRep
forall (a :: (* -> *) -> *). TypeRep a -> SomeDepRep
SomeDepRep (Typeable r_ => TypeRep r_
forall k (a :: k). Typeable a => TypeRep a
R.typeRep @r_)) HashMap SomeDepRep Dynamic
dict of
      Maybe Dynamic
Nothing ->
        DepNotFound -> r_ m
forall a e. Exception e => e -> a
throw (TypeRep -> DepNotFound
DepNotFound (Proxy (r_ m) -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy (r_ m)
forall k (t :: k). Proxy t
Proxy @(r_ m))))
      Just (Dynamic
d :: Dynamic) ->
        case Dynamic -> Maybe (Identity (r_ m))
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(Identity (r_ m)) Dynamic
d of
          Maybe (Identity (r_ m))
Nothing -> [Char] -> r_ m
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible failure converting dep."
          Just (Identity r_ m
component) -> r_ m
component

-- | Exception thrown by 'dep' when the component we are looking for is not

-- present in the environment.

newtype DepNotFound = DepNotFound TypeRep deriving (Int -> DepNotFound -> ShowS
[DepNotFound] -> ShowS
DepNotFound -> [Char]
(Int -> DepNotFound -> ShowS)
-> (DepNotFound -> [Char])
-> ([DepNotFound] -> ShowS)
-> Show DepNotFound
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

-- | In 'liftH2', mismatches in key sets are resolved by working with their

-- intersection, like how the @Apply@ instance for @Data.Map@ in the

-- \"semigroupoids\" package works.

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 . h x -> f (g x)) 
        -> DynamicEnv h m 
        -> f (DynamicEnv g m)
    traverseH :: (forall x. h x -> f (g x)) -> DynamicEnv h m -> f (DynamicEnv g m)
traverseH forall x. h x -> f (g x)
trans (DynamicEnv HashMap SomeDepRep Dynamic
dict) = HashMap SomeDepRep Dynamic -> DynamicEnv g m
forall (h :: * -> *) (m :: * -> *).
HashMap SomeDepRep Dynamic -> DynamicEnv h m
DynamicEnv (HashMap SomeDepRep Dynamic -> DynamicEnv g m)
-> f (HashMap SomeDepRep Dynamic) -> f (DynamicEnv g m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SomeDepRep -> Dynamic -> f Dynamic)
-> HashMap SomeDepRep Dynamic -> f (HashMap SomeDepRep Dynamic)
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 :: TypeRep r_ -> Dynamic -> f Dynamic
withComponent TypeRep r_
_ Dynamic
d = 
        case Dynamic -> Maybe (h (r_ m))
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(h (r_ m)) Dynamic
d of
          Maybe (h (r_ m))
Nothing -> [Char] -> f Dynamic
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible failure converting dep."
          Just h (r_ m)
hcomponent -> g (r_ m) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (g (r_ m) -> Dynamic) -> f (g (r_ m)) -> f Dynamic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> h (r_ m) -> f (g (r_ m))
forall 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 -> 
            TypeRep a -> (Typeable a => f Dynamic) -> f Dynamic
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
R.withTypeable TypeRep a
tr (TypeRep a -> Dynamic -> f Dynamic
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. a x -> f x -> f' x) ->
        -- |

        DynamicEnv a m ->
        -- |

        DynamicEnv f m ->
        -- |

        DynamicEnv f' m
    liftA2H :: (forall x. a x -> f x -> f' x)
-> DynamicEnv a m -> DynamicEnv f m -> DynamicEnv f' m
liftA2H forall x. a x -> f x -> f' x
trans (DynamicEnv HashMap SomeDepRep Dynamic
dicta) (DynamicEnv HashMap SomeDepRep Dynamic
dictb) = HashMap SomeDepRep Dynamic -> DynamicEnv f' m
forall (h :: * -> *) (m :: * -> *).
HashMap SomeDepRep Dynamic -> DynamicEnv h m
DynamicEnv ((SomeDepRep -> (Dynamic, Dynamic) -> Dynamic)
-> HashMap SomeDepRep (Dynamic, Dynamic)
-> HashMap SomeDepRep Dynamic
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
H.mapWithKey SomeDepRep -> (Dynamic, Dynamic) -> Dynamic
dynTrans ((Dynamic -> Dynamic -> (Dynamic, Dynamic))
-> HashMap SomeDepRep Dynamic
-> HashMap SomeDepRep Dynamic
-> HashMap SomeDepRep (Dynamic, Dynamic)
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 :: TypeRep r_ -> (Dynamic, Dynamic) -> Dynamic
withComponent TypeRep r_
_ (Dynamic
da, Dynamic
df)  = 
        case (Dynamic -> Maybe (a (r_ m))
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(a (r_ m)) Dynamic
da, Dynamic -> Maybe (f (r_ m))
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(f (r_ m)) Dynamic
df) of
          (Maybe (a (r_ m))
Nothing, Maybe (f (r_ m))
_) -> [Char] -> Dynamic
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible failure converting left dep."
          (Maybe (a (r_ m))
_, Maybe (f (r_ m))
Nothing) -> [Char] -> Dynamic
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible failure converting right dep."
          (Just a (r_ m)
acomponent, Just f (r_ m)
fcomponent) -> f' (r_ m) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (a (r_ m) -> f (r_ m) -> f' (r_ m)
forall 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 -> 
            TypeRep a -> (Typeable a => Dynamic) -> Dynamic
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
R.withTypeable TypeRep a
tr (TypeRep a -> (Dynamic, Dynamic) -> Dynamic
forall (r_ :: (* -> *) -> *).
Typeable r_ =>
TypeRep r_ -> (Dynamic, Dynamic) -> Dynamic
withComponent TypeRep a
tr (Dynamic, Dynamic)
dpair)

-- $setup

--

-- >>> :set -XTypeApplications

-- >>> :set -XMultiParamTypeClasses

-- >>> :set -XImportQualifiedPost

-- >>> :set -XStandaloneKindSignatures

-- >>> :set -XNamedFieldPuns

-- >>> :set -XFunctionalDependencies

-- >>> :set -XFlexibleContexts

-- >>> :set -XDataKinds

-- >>> :set -XBlockArguments

-- >>> :set -XFlexibleInstances

-- >>> :set -XTypeFamilies

-- >>> :set -XDeriveGeneric

-- >>> :set -XViewPatterns

-- >>> :set -XScopedTypeVariables

-- >>> :set -XTypeOperators

-- >>> import Data.Kind

-- >>> import Control.Monad.Dep

-- >>> import Data.Function

-- >>> import GHC.Generics (Generic)

-- >>> import Dep.Has

-- >>> import Dep.Env

-- >>> import Dep.Dynamic

-- >>> import Dep.Advice (component, runFromDep)