{-# 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
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
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
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
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 ((someTypeRep (Proxy :: Proxy a), 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 ((someTypeRep (Proxy :: Proxy a), 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 ((someTypeRep (Proxy :: Proxy a), liftProvidedValue @m b) : c))
modifiers
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), createFunction f) : mf))
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 = singletonUnsafe @m @a @ins @out
singletonUnsafe :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a))
=> Registry ins out
-> IO (Registry ins out)
singletonUnsafe r = do
cache <- newCache @a
pure $ tweakUnsafe @(m a) (fetch cache) r