{-# 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 :: 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)

-- | 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 :: 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)

-- | '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 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

-- | 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]
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 . 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)

-- $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)