{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Registry.Registry where
import Data.Registry.Internal.Cache
import Data.Registry.Internal.Types
import Data.Registry.Lift
import Data.Registry.Solver
import Data.Dynamic
import Data.Semigroup ((<>))
import Data.Text as T (unlines)
import Data.Typeable (Typeable)
import qualified Prelude (show)
import Protolude as P hiding ((<>))
import Type.Reflection
data Registry (inputs :: [*]) (outputs :: [*]) =
Registry {
_values :: Values
, _functions :: Functions
, _specializations :: Specializations
, _modifiers :: Modifiers
}
instance Show (Registry inputs outputs) where
show (Registry vs fs ss ms) =
toS $ unlines [
describeValues vs
, describeFunctions fs
, describeSpecializations ss
, describeModifiers ms
]
instance Semigroup (Registry inputs outputs) where
(<>) (Registry (Values vs1) (Functions fs1) (Specializations ss1) (Modifiers ms1))
(Registry (Values vs2) (Functions fs2) (Specializations ss2) (Modifiers ms2)) =
Registry (Values (vs1 <> vs2)) (Functions (fs1 <> fs2)) (Specializations (ss1 <> ss2)) (Modifiers (ms1 <> ms2))
instance Semigroup (Registry inputs outputs) => Monoid (Registry inputs outputs) where
mempty = Registry (Values []) (Functions []) (Specializations []) (Modifiers [])
mappend = (<>)
(<+>) :: Registry is1 os1 -> Registry is2 os2 -> Registry (is1 :++ is2) (os1 :++ os2)
(<+>) (Registry (Values vs1) (Functions fs1) (Specializations ss1) (Modifiers ms1))
(Registry (Values vs2) (Functions fs2) (Specializations ss2) (Modifiers ms2)) =
Registry (Values (vs1 <> vs2)) (Functions (fs1 <> fs2)) (Specializations (ss1 <> ss2)) (Modifiers (ms1 <> ms2))
register :: (Typeable a)
=> Typed a
-> Registry ins out
-> Registry (Inputs a :++ ins) (Output a ': out)
register (TypedValue v) (Registry (Values vs) functions specializations modifiers) =
Registry (Values (v : vs)) functions specializations modifiers
register (TypedFunction f) (Registry (Values vs) (Functions fs) specializations modifiers) =
Registry (Values vs) (Functions (f : fs)) specializations modifiers
infixr 5 +:
(+:) :: (Typeable a) => Typed a -> Registry ins out -> Registry (Inputs a :++ ins) (Output a ': out)
(+:) = register
normalize :: Registry ins out -> Registry (Normalized ins) (Normalized out)
normalize (Registry vs fs ss ms) = Registry vs fs ss ms
end :: Registry '[] '[]
end = Registry (Values []) (Functions []) (Specializations []) (Modifiers [])
val :: (Typeable a, Show a) => a -> Typed a
val a = TypedValue (ProvidedValue (toDyn a) (describeValue a))
valTo :: forall m a . (Applicative m, Typeable a, Typeable (m a), Show a) => a -> Typed (m a)
valTo a = TypedValue (liftProvidedValue @m a)
liftProvidedValue :: forall m a . (Applicative m, Typeable a, Typeable (m a), Show a) => a -> Value
liftProvidedValue a = ProvidedValue (toDyn (pure a :: m a)) (describeValue a)
fun :: (Typeable a) => a -> Typed a
fun a = TypedFunction (createFunction a)
funTo :: forall m a b . (ApplyVariadic m a b, Typeable a, Typeable b) => a -> Typed b
funTo a = fun (allTo @m a)
funAs :: forall m a b . (ApplyVariadic1 m a b, Typeable a, Typeable b) => a -> Typed b
funAs a = fun (argsTo @m a)
specialize :: forall a b ins out . (Typeable a, Contains a out, Typeable b)
=> b
-> Registry ins out
-> Registry ins out
specialize = specializeUnsafe @a @b @ins @out
specializePath :: forall path b ins out . (PathToTypeReps path, IsSubset path out, Typeable b)
=> b
-> Registry ins out
-> Registry ins out
specializePath = specializePathUnsafe @path @b @ins @out
specializeVal :: forall a b ins out . (Typeable a, Contains a out, Typeable b, Show b)
=> b
-> Registry ins out
-> Registry ins out
specializeVal = specializeUnsafeVal @a @b @ins @out
specializePathVal :: forall path b ins out . (PathToTypeReps path, IsSubset path out, Typeable b, Show b)
=> b
-> Registry ins out
-> Registry ins out
specializePathVal = specializePathUnsafeVal @path @b @ins @out
specializeValTo :: forall m a b ins out . (Applicative m, Typeable a, Contains a out, Typeable (m b), Typeable b, Show b)
=> b
-> Registry ins out
-> Registry ins out
specializeValTo = specializeUnsafeValTo @m @a @b @ins @out
specializePathValTo :: forall m path b ins out . (Applicative m, PathToTypeReps path, IsSubset path out, Typeable (m b), Typeable b, Show b)
=> b
-> Registry ins out
-> Registry ins out
specializePathValTo = specializePathUnsafeValTo @m @path @b @ins @out
specializeUnsafe :: forall a b ins out . (Typeable a, Typeable b)
=> b
-> Registry ins out
-> Registry ins out
specializeUnsafe b (Registry values functions (Specializations c) modifiers) = Registry
values
functions
(Specializations (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (createTypeableValue b) : c))
modifiers
specializePathUnsafe :: forall path b ins out . (PathToTypeReps path, Typeable b)
=> b
-> Registry ins out
-> Registry ins out
specializePathUnsafe b (Registry values functions (Specializations c) modifiers) = Registry
values
functions
(Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (createTypeableValue b) : c))
modifiers
specializeUnsafeVal :: forall a b ins out . (Typeable a, Contains a out, Typeable b, Show b)
=> b
-> Registry ins out
-> Registry ins out
specializeUnsafeVal b (Registry values functions (Specializations c) modifiers) = Registry
values
functions
(Specializations (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (createValue b) : c))
modifiers
specializePathUnsafeVal :: forall path b ins out . (PathToTypeReps path, Typeable b, Show b)
=> b
-> Registry ins out
-> Registry ins out
specializePathUnsafeVal b (Registry values functions (Specializations c) modifiers) = Registry
values
functions
(Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (createValue b) : c))
modifiers
specializeUnsafeValTo :: forall m a b ins out . (Applicative m, Typeable a, Typeable (m b), Typeable b, Show b)
=> b
-> Registry ins out
-> Registry ins out
specializeUnsafeValTo b (Registry values functions (Specializations c) modifiers) = Registry
values
functions
(Specializations (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (liftProvidedValue @m b) : c))
modifiers
specializePathUnsafeValTo :: forall m path b ins out . (Applicative m, PathToTypeReps path, Typeable (m b), Typeable b, Show b)
=> b
-> Registry ins out
-> Registry ins out
specializePathUnsafeValTo b (Registry values functions (Specializations c) modifiers) = Registry
values
functions
(Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (liftProvidedValue @m b) : c))
modifiers
class PathToTypeReps (path :: [*]) where
someTypeReps :: Proxy path -> NonEmpty SomeTypeRep
instance {-# OVERLAPPING #-} (Typeable a) => PathToTypeReps '[a] where
someTypeReps = const $ pure (someTypeRep (Proxy :: Proxy a))
instance (Typeable a, PathToTypeReps rest) => PathToTypeReps (a : rest) where
someTypeReps = const $ someTypeRep (Proxy :: Proxy a) :| toList (someTypeReps (Proxy :: Proxy rest))
tweak :: forall a ins out . (Typeable a, Contains a out)
=> (a -> a)
-> Registry ins out
-> Registry ins out
tweak = tweakUnsafe
tweakUnsafe :: forall a ins out . (Typeable a)
=> (a -> a)
-> Registry ins out
-> Registry ins out
tweakUnsafe f (Registry values functions specializations (Modifiers mf)) = Registry values functions specializations
(Modifiers ((someTypeRep (Proxy :: Proxy a), createConstModifierFunction f) : mf))
memoize :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a), Contains (m a) out)
=> Registry ins out
-> IO (Registry ins out)
memoize = memoizeUnsafe @m @a @ins @out
memoizeUnsafe :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a))
=> Registry ins out
-> IO (Registry ins out)
memoizeUnsafe (Registry values functions specializations (Modifiers mf)) = do
cache <- newCache @a
let modifiers = Modifiers ((someTypeRep (Proxy :: Proxy (m a)), \key -> createFunction (fetch @a @m cache key)) : mf)
pure $ Registry values functions specializations modifiers
memoizeAll :: forall m ins out . (MonadIO m, MemoizedActions out) => Registry ins out -> IO (Registry ins out)
memoizeAll r = _unMemoizeRegistry <$>
memoizeActions (startMemoizeRegistry r)
newtype MemoizeRegistry (todo :: [*]) (ins :: [*]) (out :: [*]) = MemoizeRegistry { _unMemoizeRegistry :: Registry ins out }
startMemoizeRegistry :: Registry ins out -> MemoizeRegistry out ins out
startMemoizeRegistry = MemoizeRegistry
makeMemoizeRegistry :: forall todo ins out . Registry ins out -> MemoizeRegistry todo ins out
makeMemoizeRegistry = MemoizeRegistry @todo
class MemoizedActions ls where
memoizeActions :: MemoizeRegistry ls ins out -> IO (MemoizeRegistry '[] ins out)
instance MemoizedActions '[] where
memoizeActions = pure
instance {-# OVERLAPPING #-} (MonadIO m, Typeable a, Typeable (m a), MemoizedActions rest) => MemoizedActions (m a : rest) where
memoizeActions (MemoizeRegistry r) = do
r' <- memoizeUnsafe @m @a r
memoizeActions (makeMemoizeRegistry @rest r')
instance (MemoizedActions rest) => MemoizedActions (a : rest) where
memoizeActions (MemoizeRegistry r) =
memoizeActions (makeMemoizeRegistry @rest r)
{-# DEPRECATED singleton "use memoize instead" #-}
singleton :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a), Contains (m a) out) => Registry ins out -> IO (Registry ins out)
singleton = memoize @m @a @ins @out
{-# DEPRECATED singletonUnsafe "use memoizeUnsafe instead" #-}
singletonUnsafe :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a)) => Registry ins out -> IO (Registry ins out)
singletonUnsafe = memoizeUnsafe @m @a @ins @out