packages feed

registry 0.5.0.0 → 0.6.0.0

raw patch · 20 files changed

+432/−411 lines, 20 filesdep +unliftio

Dependencies added: unliftio

Files

README.md view
@@ -32,7 +32,7 @@  1. how to [install this library][install]?  1. how to do [mocking][mocking]?  1. how to [specialize some values in some contexts][specialize]?- 1. how to [control effects][memoization] occurring when creating a component (like a connection pool)?+ 1. how to [control effects][caching] occurring when creating a component (like a connection pool)?  1. how to [allocate resources][resources] which must be finalized?  1. how to [extract a dot graph from the registry][dot] in an application?  1. how to [interact with a library using monad transformers](https://github.com/etorreborre/registry/blob/master/test/Test/Data/Registry/MonadRandomSpec.hs)?@@ -53,7 +53,7 @@ [mocking]: http://github.com/etorreborre/registry/blob/main/doc/applications.md#integration [install]: http://github.com/etorreborre/registry/blob/main/doc/install.md [specialize]: http://github.com/etorreborre/registry/blob/main/doc/applications.md#context-dependent-configurations-[memoization]: http://github.com/etorreborre/registry/blob/main/doc/applications.md#memoization+[caching]: http://github.com/etorreborre/registry/blob/main/doc/applications.md#caching [resources]: http://github.com/etorreborre/registry/blob/main/doc/applications.md#resources [dot]: http://github.com/etorreborre/registry/blob/main/doc/dot.md [boilerplate]: http://github.com/etorreborre/registry/blob/main/doc/boilerplate.md
registry.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f5f64917e56100dee68b1a07abc7a53b5e323440dfeb36623410f015fb2129c5+-- hash: eba4b73d85a7c3fbee86501abdf3870e4af595503b7879280fad3c2baecbb4c1  name:           registry-version:        0.5.0.0+version:        0.6.0.0 synopsis:       data structure for assembling components description:    This library provides a "Registry" which is a data structure containing a list of functions and values representing dependencies in a directed acyclic graph. A `make` function can then be used to create a value of a specific type out of the registry.                 You can start with the [README](https://github.com/etorreborre/registry/blob/master/README.md) for a full description of the library.@@ -40,7 +40,7 @@       Data.Registry.Lift       Data.Registry.Make       Data.Registry.Registry-      Data.Registry.RIO+      Data.Registry.Rio       Data.Registry.Solver       Data.Registry.State       Data.Registry.Statistics@@ -77,6 +77,7 @@     , template-haskell >=2.13 && <3.0     , text >=1.1 && <2     , transformers-base ==0.4.*+    , unliftio >=0.2 && <1   default-language: GHC2021  test-suite spec@@ -86,7 +87,6 @@       AutoDiscoveredSpecs       Test.Data.Registry.DotSpec       Test.Data.Registry.GenSpec-      Test.Data.Registry.Internal.CacheSpec       Test.Data.Registry.Internal.DynamicSpec       Test.Data.Registry.Internal.Gens       Test.Data.Registry.Internal.GensRegistry@@ -95,7 +95,7 @@       Test.Data.Registry.Internal.RegistrySpec       Test.Data.Registry.Internal.TypesSpec       Test.Data.Registry.Make.MakeSpec-      Test.Data.Registry.Make.MemoizeSpec+      Test.Data.Registry.Make.RioSpec       Test.Data.Registry.Make.SpecializationFunctionsSpec       Test.Data.Registry.Make.SpecializationSpec       Test.Data.Registry.Make.TweakingSpec@@ -159,4 +159,5 @@     , text <2     , transformers-base ==0.4.*     , universum <2+    , unliftio >=0.2 && <1   default-language: GHC2021
src/Data/Registry.hs view
@@ -11,7 +11,7 @@ import Data.Registry.Dot as M -- Produce a graph out of a registry import Data.Registry.Lift as M -- Lift functions into a monadic context import Data.Registry.Make as M -- Various "make" functions to create components from a registry-import Data.Registry.RIO as M -- ResourceT monad for effectful instantiation+import Data.Registry.Rio as M -- ResourceT + cache monad for effectful instantiation and singletons import Data.Registry.Registry as M -- The Registry data structure import Data.Registry.Solver as M -- Type-level constraints to check if we can make a component from a registry import Data.Registry.Statistics as M -- Provide statistics about the execution of a registry
src/Data/Registry/Internal/Cache.hs view
@@ -1,38 +1,108 @@--- |------ Cache for individual IO values when we wish to memoize actions--- for database connection pools for example------ This is inspired by https://hackage.haskell.org/package/io-memoize+{-# LANGUAGE AllowAmbiguousTypes #-}++{- Cache for Rio values, backed by a MVar -} module Data.Registry.Internal.Cache where -import Data.Map.Strict-import Data.Registry.Internal.Types (SpecializationPath)-import Protolude as P+import Data.Dynamic+import Data.Map as M hiding (singleton)+import Data.Map qualified as M+import Data.Registry.Internal.Reflection (showSingleType)+import Protolude+import Type.Reflection (someTypeRep) --- | A thread-safe write-once cache. If you need more functionality,--- (e.g. multiple write, cache clearing) use an 'MVar' instead.-newtype Cache a = Cache (MVar (Map Key a))-  deriving (Eq, Typeable)+-- * EXPORTED FUNCTIONS --- | We need to cache different values to account for the fact---   that different values might be specialized for the same type-type Key = Maybe [SpecializationPath]+-- | Cache an effectful value with a given text key+--   so that the value is not recreated for the same key+cacheAt :: forall a m. (Typeable a, MonadIO m, MonadReader Cache m) => Text -> m a -> m a+cacheAt = cacheAtKey . Custom --- | Fetch the value stored in the cache,--- or call the supplied fallback and store the result,--- if the cache is empty.-fetch :: forall a m. (MonadIO m, Typeable a) => Cache a -> Key -> m a -> m a-fetch (Cache var) key action = do-  m <- liftIO $ P.readMVar var-  case lookup key m of+-- | Cache an effectful value by using its type as the cache key+singleton :: forall a m. (Typeable a, MonadIO m, MonadReader Cache m) => m a -> m a+singleton = cacheAtKey Singleton++-- * IMPLEMENTATION++-- | A cache for created values, with a map from+--   the textual representation of a type to various cached values+newtype Cache = Cache (MVar (Map Text Cached))+  deriving (Eq)++-- | Cache for a value of a single type+--   There is at most one singleton and possibly some custom values, indexed by a specific key+data Cached = Cached+  { singletonCached :: Maybe Dynamic,+    customCached :: Map Text Dynamic+  }+  deriving (Show)++-- | An empty cached value (with no cached instances yet)+emptyCached :: Cached+emptyCached = Cached Nothing mempty++-- | Create an empty cache+newCache :: MonadIO m => m Cache+newCache = liftIO $ Cache <$> newMVar mempty++-- | Get the current cache+askCache :: MonadReader Cache m => m Cache+askCache = ask++-- | Type of keys used to cache values+--   A value can either be cached with a specific key, or it is a singleton+data Key+  = Custom Text+  | Singleton+  deriving (Eq, Show, Ord)++-- | Make sure that an effectful value is cached after the first evaluation for a specific key+cacheAtKey :: forall a m. (Typeable a, MonadIO m, MonadReader Cache m) => Key -> m a -> m a+cacheAtKey key action = do+  m <- getCached @a key+  case m of     Just a ->       pure a     Nothing -> do-      val <- action-      liftIO $ modifyMVar_ var (pure . insert key val)-      pure val+      a <- action+      setCached key a+      pure a --- | Create an empty cache.-newCache :: IO (Cache a)-newCache = Cache <$> P.newMVar mempty+-- | Get a cached value from the cache+--   This is a IO operation since we access the cache MVar+getCached :: (Typeable a, MonadIO m, MonadReader Cache m) => Key -> m (Maybe a)+getCached key = askCache >>= getCachedValue key++-- | Cache a value at a given key in the cache+--   This is a IO operation since we access the cache MVar+setCached :: forall a m. (Typeable a, MonadIO m, MonadReader Cache m) => Key -> a -> m ()+setCached key a =+  askCache >>= cacheValue+  where+    -- \| Cache a value as a Dynamic value for a given key+    cacheValue :: Cache -> m ()+    cacheValue (Cache ms) = liftIO $+      modifyMVar_ ms $+        \m -> pure (M.alter (cacheDynValue key (toDyn a)) (makeTypeText @a) m)++-- | Retrieve a cached value given its key+getCachedValue :: forall a m. (Typeable a, MonadIO m) => Key -> Cache -> m (Maybe a)+getCachedValue key (Cache ms) = liftIO $ do+  m <- readMVar ms+  let c = lookup (makeTypeText @a) m+  pure $ c >>= getDynValue key >>= fromDynamic @a++-- | Insert a (dynamic) value in the Cached data structure for a specific type of value+cacheDynValue :: Key -> Dynamic -> Maybe Cached -> Maybe Cached+cacheDynValue Singleton dynamic Nothing = Just $ emptyCached {singletonCached = Just dynamic}+cacheDynValue Singleton dynamic (Just cached) = Just $ cached {singletonCached = singletonCached cached <|> Just dynamic}+cacheDynValue (Custom key) dynamic Nothing = Just $ emptyCached {customCached = M.singleton key dynamic}+cacheDynValue (Custom key) dynamic (Just cached) = Just $ cached {customCached = M.insert key dynamic $ customCached cached}++-- | Return the dynamic value cached at a given key+getDynValue :: Key -> Cached -> Maybe Dynamic+getDynValue Singleton (Cached s _) = s+getDynValue (Custom k) (Cached _ m) = M.lookup k m++-- | Return a textual description of a Haskell type+makeTypeText :: forall a. (Typeable a) => Text+makeTypeText = showSingleType $ someTypeRep (Proxy :: Proxy a)
src/Data/Registry/Internal/Dynamic.hs view
@@ -29,7 +29,7 @@   do     created <- applyFunctionDyn (funDyn function) (valueDyn <$> values)     let description = ValueDescription (_outputType . funDescription $ function) Nothing-    let dependencies = foldMap dependenciesOn values+    let dependencies = foldMap dependenciesOf values      pure $ makeCreatedValue created description dependencies
src/Data/Registry/Internal/Registry.hs view
@@ -86,5 +86,5 @@     modifyValue :: Value -> [(SomeTypeRep, ModifierFunction)] -> Stack Value     modifyValue v [] = pure v     modifyValue v ((_, f) : rest) = do-      applied <- lift $ applyModification (f (specializationPaths v)) v+      applied <- lift $ applyModification (f (specializedContexts v)) v       modifyValue applied rest
src/Data/Registry/Internal/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- |@@ -229,7 +230,6 @@ untypedDyn (UntypedFunction f) = funDyn f untypedDyn (UntypedValue v) = valueDyn v - -- | This is a list of entries in the registry available for constructing values --   They are sorted by output type and if there are several available functions or values --   for a given type the first one in the list has the highest priority@@ -338,8 +338,8 @@ dependenciesTypes (Dependencies ds) = DependenciesTypes (valueDynTypeRep <$> ds)  -- | The dependencies of a value + the value itself-dependenciesOn :: Value -> Dependencies-dependenciesOn value = Dependencies $ value : (unDependencies . valueDependencies $ value)+dependenciesOf :: Value -> Dependencies+dependenciesOf value = Dependencies $ value : (unDependencies . valueDependencies $ value)  -- | Specification of values which become available for --   construction when a corresponding type comes in context@@ -350,8 +350,8 @@  -- | A specialization is defined by --   a path of types, from top to bottom in the---    value graph and target value, which is the---   value to use when we need a value on that type+--    value graph and a target value, which is the+--   value to use when we need a value of that type --   on that path. --   For example: --      specializationPath = [App, PaymentEngine, TransactionRepository]@@ -370,13 +370,20 @@ --   See the comments on 'Specialization' type SpecializationPath = NonEmpty SomeTypeRep --- | Return the various specialization paths which have possibly led to the---   creation of that value-specializationPaths :: Value -> Maybe [SpecializationPath]-specializationPaths v =-  case mapMaybe valueSpecialization (unDependencies $ dependenciesOn v) of-    [] -> Nothing-    ss -> Just (_specializationPath <$> ss)+-- | For each dependency of the value+--   Return the specialization context of the value if+--     - that dependency value is specialized+--     - the current value is part of the context stack and part of a context path+specializedContexts :: Value -> [SpecializationContext]+specializedContexts v = do+  let contexts = mapMaybe valueSpecializationContext (unDependencies $ dependenciesOf v)+  P.filter isCurrentValueSpecialized contexts+  where+    isCurrentValueSpecialized (SpecializationContext (Context stack) (Specialization path _)) = do+      let stackTypes = fst <$> stack+      let topSpecializedType = NonEmpty.head path+      let specializedTypes = P.takeWhile (/= topSpecializedType) stackTypes+      valueDynTypeRep v `elem` (topSpecializedType : specializedTypes)  -- | First type of a specialization specializationStart :: Specialization -> SomeTypeRep@@ -475,7 +482,7 @@ --   then the specialization path is also passed to the function --   This is used for memoizing actions using a cache so that we --   cache each specialized value separately.-type ModifierFunction = Maybe [SpecializationPath] -> Function+type ModifierFunction = [SpecializationContext] -> Function  -- | Create a 'ModifierFunction' value from a Haskell function --   The application of that function does not depend on the fact@@ -483,6 +490,13 @@ createConstModifierFunction :: (Typeable f) => f -> ModifierFunction createConstModifierFunction f = const (createFunction f) +-- | Create a 'ModifierFunction' value from a Haskell function+--   that will only act on unspecialized values+createUnspecializedModifierFunction :: forall a f. (Typeable f, Typeable a, Typeable (a -> a)) => f -> ModifierFunction+createUnspecializedModifierFunction f = \case+    [] -> createFunction f+    _ -> createFunction @(a -> a) identity+ instance Show Modifiers where   show = toS . describeModifiers @@ -493,7 +507,6 @@   if P.null ms     then ""     else "modifiers for types\n" <> unlines (P.show . fst <$> ms)-  -- * VALUES
− src/Data/Registry/RIO.hs 
@@ -1,34 +0,0 @@--- | Utilities for working with ResourceT IO-module Data.Registry.RIO where--import Control.Monad.Trans.Resource-import Data.Registry.Make-import Data.Registry.Registry-import Data.Registry.Solver-import Protolude---- | Type alias for ResourceT IO-type RIO = ResourceT IO---- | This function must be used to run services involving a top component---   It creates an application of type a and which can return a result of type b.------   We also make sure that all effects are memoized by calling `memoizeAll` on the Registry here!-withRegistry ::-  forall a b ins out m.-  (Typeable a, Contains (RIO a) out, Solvable ins out, MonadIO m, MemoizedActions out) =>-  Registry ins out ->-  (a -> IO b) ->-  m b-withRegistry registry f = liftIO $-  runResourceT (runRegistryT @a registry >>= liftIO . f)---- | This can be used if you want to insert the component creation inside---   another action managed with ResourceT. Or if you want to call runResourceT yourself later-runRegistryT ::-  forall a ins out .-  (Typeable a, Contains (RIO a) out, Solvable ins out, MemoizedActions out) =>-  Registry ins out ->-  ResourceT IO a-runRegistryT registry =-  liftIO (memoizeAll @RIO registry) >>= make @(RIO a)
src/Data/Registry/Registry.hs view
@@ -36,7 +36,6 @@ module Data.Registry.Registry where  import Data.Dynamic-import Data.Registry.Internal.Cache import Data.Registry.Internal.Types import Data.Registry.Lift import Data.Registry.Solver@@ -267,57 +266,12 @@     specializations     (Modifiers ((someTypeRep (Proxy :: Proxy a), createConstModifierFunction f) : mf)) --- * Memoization---- | Instantiating components can trigger side-effects---   The way the resolution algorithm works a component of type `m a` will be---   re-executed *every time* it is needed as a given dependency---   This section adds support for memoizing those actions---- | Return memoized values for a monadic type---   Note that the returned Registry is in 'IO' because we are caching a value---   and this is a side-effect!-memoize :: forall m a ins out. (MonadIO m, Typeable a, Typeable (m a)) => Registry ins out -> IO (Registry ins out)-memoize (Registry entries specializations (Modifiers mf)) = do-  cache <- newCache @a-  let modifiers = Modifiers ((someTypeRep (Proxy :: Proxy (m a)), createFunction . fetch @a @m cache) : mf)-  pure $ Registry entries specializations modifiers---- | Memoize *all* the output actions of a Registry when they are creating effectful components---   This relies on a helper data structure `MemoizeRegistry` tracking the types already---   memoized and a typeclass MemoizedActions going through the list of out types to process them---   one by one. Note that a type of the form a will not be memoized (only `m a`)-memoizeAll :: forall m ins out. (MonadIO m, MemoizedActions out) => Registry ins out -> IO (Registry ins out)-memoizeAll r =-  _unMemoizeRegistry-    <$> memoizeActions (startMemoizeRegistry r)---- | Registry where all output values are memoized-newtype MemoizeRegistry (todo :: [Type]) (ins :: [Type]) (out :: [Type]) = MemoizeRegistry {_unMemoizeRegistry :: Registry ins out}---- | Prepare a Registry for memoization-startMemoizeRegistry :: Registry ins out -> MemoizeRegistry out ins out-startMemoizeRegistry = MemoizeRegistry---- | Prepare a Registry for memoization for a specific list of types-makeMemoizeRegistry :: forall todo ins out. Registry ins out -> MemoizeRegistry todo ins out-makeMemoizeRegistry = MemoizeRegistry @todo---- | This typeclass take an existing registry and memoize values created for the ls types-class MemoizedActions ls where-  memoizeActions :: MemoizeRegistry ls ins out -> IO (MemoizeRegistry '[] ins out)---- | If the list of types is empty there is nothing to memoize-instance MemoizedActions '[] where-  memoizeActions = pure---- | If the type represents an effectful value, memoize it and recurse with the rest-instance {-# OVERLAPPING #-} (MonadIO m, Typeable a, Typeable (m a), MemoizedActions rest) => MemoizedActions (m a : rest) where-  memoizeActions (MemoizeRegistry r) = do-    r' <- memoize @m @a r-    memoizeActions (makeMemoizeRegistry @rest r')---- | If the type represents a pure value, memoize the rest-instance (MemoizedActions rest) => MemoizedActions (a : rest) where-  memoizeActions (MemoizeRegistry r) =-    memoizeActions (makeMemoizeRegistry @rest r)+-- | Once a value has been computed allow to modify it before storing it+--   This keeps the same registry type+--   This only tweaks unspecialized values!+tweakUnspecialized :: forall a ins out. (Typeable a) => (a -> a) -> Registry ins out -> Registry ins out+tweakUnspecialized f (Registry entries specializations (Modifiers mf)) =+  Registry+    entries+    specializations+    (Modifiers ((someTypeRep (Proxy :: Proxy a), createUnspecializedModifierFunction @a f) : mf))
+ src/Data/Registry/Rio.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}++-- | Utilities for working with resources+module Data.Registry.Rio+  ( module Data.Registry.Rio,+    singleton,+    cacheAt+  )+where++import Control.Monad.Morph+import Control.Monad.Trans.Resource+import Data.Dynamic+import Data.Registry.Internal.Cache+import Data.Registry.Make (make)+import Data.Registry.Registry+import Protolude++-- | This data type provides some support for creating effectful components with resources+--   You can use the regular MonadResource functions like allocate to make sure that resources are cleaned up+--   You can also use the 'cacheAt' function+newtype Rio a = Rio {rioRun :: ReaderT Cache (ResourceT IO) a}+  deriving (Functor, Applicative, Monad, MonadReader Cache, MonadIO, MonadResource, MonadUnliftIO)++-- | Run a Rio action by providing an empty cache and allocating / destroying resources+runRio :: MonadIO m => Rio a -> m a+runRio = liftIO . runResourceT . runCache++-- | Run a Rio action by providing an empty cache and allocating / destroying resources+execRio :: MonadIO m => Rio a -> m (a, Cache)+execRio = liftIO . runResourceT . execCache++-- | Use the value created by a Rio action so that resources are properly allocated and cached+withRio :: MonadIO m => Rio a -> (a -> IO b) -> m b+withRio action f = liftIO . runResourceT $ do+  a <- runCache action+  liftIO $ f a++-- | Use the value created by a Rio action so that resources are properly allocated and cached+--   inside a monad transformer+withRioM :: (MonadResource (m (ResourceT IO)), MFunctor m) => Rio a -> (a -> m IO b) -> m IO b+withRioM action f = hoist runResourceT $ do+  a <- liftResourceT (runCache action)+  hoist lift (f a)++-- | Run a Rio action by providing an empty cache+runCache :: Rio a -> ResourceT IO a+runCache (Rio action) = do+  cache <- liftIO newCache+  runReaderT action cache++-- | Run a Rio action by providing an empty cache, and return the final cache+--   for inspection+execCache :: Rio a -> ResourceT IO (a, Cache)+execCache (Rio action) = do+  cache <- liftIO newCache+  (,cache) <$> runReaderT action cache++-- | Lift a resourceful value into Rio+liftRio :: ResourceT IO a -> Rio a+liftRio = Rio . lift++-- | This function must be used to run services involving resources+--   The value a is created using the registry, used with the function 'f'+--   and all resources are freed at the end+withRegistry :: forall a b ins out m. (Typeable a, MonadIO m, MakeSingletons out) => Registry ins out -> (a -> IO b) -> m b+withRegistry registry f =+  liftIO $ runResourceT (runRegistryT @a registry >>= liftIO . f)++-- | This function works like 'withRegistry' for a higher-order monad, typically `PropertyT IO` when+--   writing property tests with Hedgehog+withRegistryM ::+  forall a b ins out m.+  (Typeable a, MonadResource (m (ResourceT IO)), MFunctor m, MakeSingletons out) =>+  Registry ins out ->+  (a -> m IO b) ->+  m IO b+withRegistryM = withRioM . make @(Rio a) . singletons++-- | Create a function of type a with a given registry+--   Return a ResourceT value to control resource allocation+runRegistryT :: forall a ins out. (Typeable a, MakeSingletons out) => Registry ins out -> ResourceT IO a+runRegistryT = runCache . make @(Rio a) . singletons++-- | Make singletons for all the output types of a registry+--   but only if they not specialized values+singletons :: forall ins out. (MakeSingletons out) => Registry ins out -> Registry ins out+singletons r = _singletonsRegistry $ makeSingletons (startSingletonsRegistry r)++-- | Registry where all Rio values are singletons+newtype SingletonsRegistry (todo :: [Type]) (ins :: [Type]) (out :: [Type]) = SingletonsRegistry {_singletonsRegistry :: Registry ins out}++-- | Prepare a Registry for making singletons+startSingletonsRegistry :: Registry ins out -> SingletonsRegistry out ins out+startSingletonsRegistry = SingletonsRegistry++-- | Prepare a Registry for making singletons on a specific list of types+makeSingletonsRegistry :: forall todo ins out. Registry ins out -> SingletonsRegistry todo ins out+makeSingletonsRegistry = SingletonsRegistry @todo++-- | This typeclass take an existing registry and makes a singleton for each Rio output type+class MakeSingletons ls where+  makeSingletons :: SingletonsRegistry ls ins out -> SingletonsRegistry '[] ins out++-- | If the list of types is empty there is nothing to do+instance MakeSingletons '[] where+  makeSingletons = identity++-- | If the type represents an effectful value, make a singleton for it and recurse on the rest+instance {-# OVERLAPPING #-} (Typeable a, MakeSingletons rest) => MakeSingletons (Rio a : rest) where+  makeSingletons (SingletonsRegistry r) =+    makeSingletons $ SingletonsRegistry @rest (tweakUnspecialized @(Rio a) singleton r)++-- | If the type represents a pure value, make singletons for the rest+instance (MakeSingletons rest) => MakeSingletons (a : rest) where+  makeSingletons (SingletonsRegistry r) = makeSingletons (makeSingletonsRegistry @rest r)
− test/Test/Data/Registry/Internal/CacheSpec.hs 
@@ -1,22 +0,0 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}--module Test.Data.Registry.Internal.CacheSpec where--import Control.Concurrent.Async-import Data.Registry.Internal.Cache-import Protolude as P-import Test.Tasty.Extensions--test_cache = test "caching an IO action must always return the same value" $ do-  cached <- liftIO $ do-    -- create an action which will increment an Int everytime it is called-    ref <- newMVar (0 :: Int)-    let action = modifyMVar_ ref (pure . (+ 1)) >> readMVar ref-    cache <- newCache--    -- when the action is cached it will always return the same value-    let cachedAction = fetch cache Nothing action-    void $ replicateConcurrently_ 100 cachedAction -- with concurrent accesses-    cachedAction--  cached === 1
− test/Test/Data/Registry/Make/MemoizeSpec.hs 
@@ -1,159 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}--module Test.Data.Registry.Make.MemoizeSpec where--import Data.IORef-import Data.Registry-import Protolude hiding (C1, D1)-import System.IO.Memoize-import Test.Tasty.Extensions--test_memoize = test "effectful values can be memoized with System.IO.Memoize" $ do-  (c1, c2) <- liftIO $ do-    -- create a counter for the number of instantiations-    counter <- newIORef 0--    newSingOnce <- once (newSing counter)-    let r =-          funTo @IO newC1-            <: funTo @IO newC2-            <: funTo @IO newSingOnce--    c1 <- make @(IO C1) r-    c2 <- make @(IO C2) r-    pure (c1, c2)--  c1 === C1 (Sing 1)-  c2 === C2 (Sing 1)--test_memoize_proper = test "effectful values can memoized" $ do-  (c1, c2) <- liftIO $ do-    -- create a counter for the number of instantiations-    counter <- newIORef 0--    let r =-          funTo @IO newC1-            <: funTo @IO newC2-            <: funTo @IO (newSing counter)--    r' <- memoize @IO @Sing r-    c1 <- make @(IO C1) r'-    c2 <- make @(IO C2) r'-    pure (c1, c2)--  c1 === C1 (Sing 1)-  c2 === C2 (Sing 1)--test_automatic_memoize_all_for_with_registry = test "withRegistry automatically uses memoizeAll with RIO" $ do-  messagesRef <- liftIO $ newIORef []-  let registry =-        funTo @RIO App-          <: funTo @RIO newA-          <: funTo @RIO newB-          <: fun (newC messagesRef)--  --  just instantiate the app for its effects-  withRegistry @App registry $ \_ -> pure ()--  ms <- liftIO $ readIORef messagesRef--  annotate "if memoize works properly, then only one instantiation is invoked"-  ms === ["x"]--test_memoize_with_specialization = test "all the values on a specialization path are memoized independently" $ do-  D3 d1 d2 <- liftIO $ do-    -- create a counter for the number of instantiations-    counter <- newIORef 0--    let r =-          specialize @(IO D2) @(IO Specialized) (valTo @IO Specialized2) $-            funTo @IO D3-              <: funTo @IO D1-              <: funTo @IO D2-              <: funTo @IO (newCounter counter)-              <: valTo @IO Specialized1--    r' <- memoizeAll @IO r-    make @(IO D3) r'--  d1 === D1 (Counter 1 Specialized1)-  d2 === D2 (Counter 2 Specialized2)--test_memoize_with_specialized_functions = test "all the values created from functions on a specialization path are memoized independently" $ do-  D3 d1 d2 <- liftIO $ do-    -- create a counter for the number of instantiations-    counter <- newIORef 0--    let r =-          specialize @(IO D2) (funTo @IO (\(_ :: Text) -> Specialized2)) $-            funTo @IO D3-              <: funTo @IO D1-              <: funTo @IO D2-              <: funTo @IO (newCounter counter)-              <: valTo @IO Specialized1-              <: valTo @IO ("text" :: Text)--    r' <- memoizeAll @IO r-    make @(IO D3) r'--  d1 === D1 (Counter 1 Specialized1)-  d2 === D2 (Counter 2 Specialized2)---- * HELPERS--newtype C1 = C1 Sing deriving (Eq, Show)--newC1 :: Sing -> IO C1-newC1 = pure . C1--newtype C2 = C2 Sing deriving (Eq, Show)--newC2 :: Sing -> IO C2-newC2 = pure . C2--newtype Sing = Sing Int deriving (Eq, Show)--newSing :: IORef Int -> IO Sing-newSing counter = do-  _ <- modifyIORef counter (+ 1)-  i <- readIORef counter-  pure (Sing i)--data C3 = C3 C1 C2 deriving (Eq, Show)--newtype A = A {doItA :: IO ()}--newtype B = B {doItB :: IO ()}--newtype C = C {doItC :: IO ()}--newA :: C -> A-newA c = A {doItA = doItC c}--newB :: C -> B-newB c = B {doItB = doItC c}--newC :: IORef [Text] -> RIO C-newC messagesRef = do-  let c = C {doItC = pure ()}-  liftIO $ modifyIORef messagesRef ("x" :)-  pure c--data App = App {a :: A, b :: B}--newtype D1 = D1 Counter deriving (Eq, Show)--newtype D2 = D2 Counter deriving (Eq, Show)--data Counter = Counter Int Specialized deriving (Eq, Show)--data Specialized = Specialized1 | Specialized2 deriving (Eq, Show)--newCounter :: IORef Int -> Specialized -> IO Counter-newCounter counter specialized = do-  _ <- modifyIORef counter (+ 1)-  i <- readIORef counter-  pure (Counter i specialized)--data D3 = D3 D1 D2 deriving (Eq, Show)
+ test/Test/Data/Registry/Make/RioSpec.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.Make.RioSpec where++import Control.Monad.Trans.Resource+import Data.IORef+import Data.Map as M hiding (singleton)+import Data.Registry as Rio+import Protolude hiding (C1, D1)+import Test.Tasty.Extensions++test_fmap = test "a cached value can still be mapped over" $ do+  -- count the number of creation for the counter+  creations <- liftIO (newIORef (0 :: Int))++  -- create a singleton counter starting at 1+  let counter = Rio.singleton $ liftIO $ do+        c <- newIORef (1 :: Int)+        modifyIORef creations (+ 1)+        pure c++  -- make the counter once, then make the counter start at 2+  c1 <- liftIO (newIORef (2 :: Int))+  ref <- runRio (counter >> (counter $> c1))++  -- the counter starts at 2+  incremented <- liftIO . readIORef $ ref+  incremented === 2++  -- the counter has been created only once+  created <- liftIO . readIORef $ creations+  created === 1++test_singletons_with_specialization = test "some effectful components can be cached to become singletons in some contexts" $ do+  let registry =+        singletons $+          specialize @(Rio Storage3) (valTo @Rio (DatabaseConfig "localhost" 9876)) $+            funTo @Rio newApp+              <: funTo @Rio newBusinessLogic+              <: funTo @Rio Storage3+              <: funTo @Rio Storage2+              <: funTo @Rio Storage1+              <: funTo @Rio newConnectionPool+              <: fun newCounter+              <: valTo @Rio (DatabaseConfig "localhost" 5432)++  withRegistryM @App registry $ \App {..} -> do+    let db1 = getDatabaseConfig $ getStorage1ConnectionPool storage1+    let db2 = getDatabaseConfig $ getStorage2ConnectionPool storage2+    let db3 = getDatabaseConfig $ getStorage3ConnectionPool storage3++    db1 === db2+    db2 /== db3+    db3 === DatabaseConfig "localhost" 9876++    n <- readCounter counter+    n+      === [ ("create the App", 1),+            ("create the BusinessLogic", 1),+            ("http://localhost:5432", 1),+            ("http://localhost:9876", 1)+          ]++-- * HELPERS++data App = App+  { storage1 :: Storage1,+    storage2 :: Storage2,+    storage3 :: Storage3,+    businessLogic :: BusinessLogic,+    counter :: Counter+  }++newApp :: Counter -> Storage1 -> Storage2 -> Storage3 -> BusinessLogic -> Rio App+newApp counter s1 s2 s3 bl = do+  incrementCounter counter "create the App"+  pure (App s1 s2 s3 bl counter)++newtype ConnectionPool = ConnectionPool {getDatabaseConfig :: DatabaseConfig}++newConnectionPool :: Counter -> DatabaseConfig -> Rio ConnectionPool+newConnectionPool counter config = do+  let key = databaseConfigUrl config++  let create = do+        -- count the number of times that a pool is created with some specific parameters+        incrementCounter counter (databaseConfigUrl config)+        pure (ConnectionPool config)+  let destroy = const $ pure ()++  cacheAt key (snd <$> allocate create destroy)++data DatabaseConfig = DatabaseConfig {host :: Text, port :: Int} deriving (Eq, Show)++databaseConfigUrl :: DatabaseConfig -> Text+databaseConfigUrl (DatabaseConfig h p) = "http://" <> h <> ":" <> show p++newtype Storage1 = Storage1 {getStorage1ConnectionPool :: ConnectionPool}++newtype Storage2 = Storage2 {getStorage2ConnectionPool :: ConnectionPool}++newtype Storage3 = Storage3 {getStorage3ConnectionPool :: ConnectionPool}++newtype Counter = Counter (IORef (Map Text Int))++newtype BusinessLogic = BusinessLogic Storage1++newBusinessLogic :: Counter -> Storage1 -> Storage3 -> Rio BusinessLogic+newBusinessLogic counter storage1 _storage3 = do+  incrementCounter counter "create the BusinessLogic"+  pure $ BusinessLogic storage1++newCounter :: Rio Counter+newCounter = Counter <$> liftIO (newIORef mempty)++incrementCounter :: MonadIO m => Counter -> Text -> m ()+incrementCounter (Counter ref) key = liftIO $ do+  m <- readIORef ref+  let current = fromMaybe 0 (M.lookup key m)+  modifyIORef ref $ pure (M.insert key (current + 1) m)++readCounter :: MonadIO m => Counter -> m (Map Text Int)+readCounter (Counter ref) = liftIO $ readIORef ref
test/Test/Data/Registry/Make/SpecializationSpec.hs view
@@ -111,18 +111,18 @@   (c1, c2, c3) <- liftIO $     do       let r =-            funTo @RIO newBase2-              <: funTo @RIO newClient1-              <: funTo @RIO newClient2-              <: funTo @RIO newUseConfig-              <: valTo @RIO (Config 3)+            funTo @Rio newBase2+              <: funTo @Rio newClient1+              <: funTo @Rio newClient2+              <: funTo @Rio newUseConfig+              <: valTo @Rio (Config 3)        let r' =-            specializePath @[RIO Base2, RIO Client1, RIO UseConfig] (valTo @RIO $ Config 1)-              . specialize @(RIO UseConfig) (valTo @RIO $ Config 2)+            specializePath @[Rio Base2, Rio Client1, Rio UseConfig] (valTo @Rio $ Config 1)+              . specialize @(Rio UseConfig) (valTo @Rio $ Config 2)               $ r -      printBase2 <$> runResourceT (make @(RIO Base2) r')+      printBase2 <$> runResourceT (runRegistryT @Base2 r')    c1 === Config 1   c2 === Config 2@@ -214,46 +214,6 @@   StatsStore     { statsStoreConfig = (twitterConfig client, sqlConfig sql, supervisorConfig supervisor)     }---- | Case 6 (taken from a real case...)-test_specialization_6 = test "specialized values must not be affected by memoization" $ do-  someData <- liftIO $ do-    r <- aRegistryIO-    make @(IO SomeData) r--  (someData & toOverride & toOverrideConfig) === ("specialized config" :: Text)-  (someData & toKeepDefault & toKeepDefaultConfig) === ("default config" :: Text)--data SomeData = SomeData-  { toKeepDefault :: ToKeepDefault,-    toOverride :: ToOverride,-    inCommon :: InCommon-  }--newtype ToOverride = ToOverride {toOverrideConfig :: Text}--newtype ToKeepDefault = ToKeepDefault {toKeepDefaultConfig :: Text}--newtype InCommon = InCommon {config :: SomeConfig}--newtype SomeConfig = SomeConfig Text deriving (Eq, Show)--newToKeepDefault :: InCommon -> ToKeepDefault-newToKeepDefault (InCommon (SomeConfig t)) = ToKeepDefault {toKeepDefaultConfig = t}--newToOverride :: InCommon -> ToOverride-newToOverride (InCommon (SomeConfig t)) = ToOverride {toOverrideConfig = t}--aRegistryIO :: IO (Registry _ _)-aRegistryIO =-  memoizeAll @IO $-    specializePath @[IO ToOverride, IO InCommon] (valTo @IO $ SomeConfig "specialized config") $-      funTo @IO SomeData-        <: funTo @IO newToKeepDefault-        <: funTo @IO newToOverride-        <: funTo @IO InCommon-        <: fun (\(c:: IO SomeConfig) -> InCommon <$> c)-        <: valTo @IO (SomeConfig "default config")  test_make_specialized_values = test "specialized values can be made" $ do   let r =
test/Test/Data/Registry/RegistrySpec.hs view
@@ -81,17 +81,17 @@ a :: Int -> Int -> IO Int a _ _ = pure 0 -b :: Int -> Int -> RIO Int-b = outTo @RIO liftIO a+b :: Int -> Int -> Rio Int+b = outTo @Rio liftIO a -c :: RIO Int -> RIO Int -> RIO Int-c = allTo @RIO b+c :: Rio Int -> Rio Int -> Rio Int+c = allTo @Rio b  -- here the result of outTo needs to be explicit--- otherwise the type of d is RIO (Int -> Int -> RIO Int)-d :: RIO Int -> RIO Int -> RIO Int-d = allTo @RIO (outTo @RIO liftIO a :: Int -> Int -> RIO Int)+-- otherwise the type of d is Rio (Int -> Int -> Rio Int)+d :: Rio Int -> Rio Int -> Rio Int+d = allTo @Rio (outTo @Rio liftIO a :: Int -> Int -> Rio Int)  -- to avoid the issue with type inference above, we can use argsTo-e :: RIO Int -> RIO Int -> RIO Int-e = argsTo @RIO (outTo @RIO liftIO a)+e :: Rio Int -> Rio Int -> Rio Int+e = argsTo @Rio (outTo @Rio liftIO a)
test/Test/Tutorial/Exercise1.hs view
@@ -8,7 +8,7 @@       console' = newConsole       userInput' = newUserInput console'       rng' = newRng logger'-      secretReader' = newSecretReader (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") logger'+      secretReader' = newSecretReader (SecretReaderConfig "test/Test/Tutorial/secret.txt") logger'    in App         { userInput = userInput',           console = console',
test/Test/Tutorial/Exercise2.hs view
@@ -14,7 +14,7 @@     <: fun newRng     <: fun newConsole     <: fun newLogger-    <: val (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt")+    <: val (SecretReaderConfig "test/Test/Tutorial/secret.txt")  newApp :: App newApp = make @App registry
test/Test/Tutorial/Exercise5.hs view
@@ -10,10 +10,10 @@ import System.Directory (doesFileExist) import Test.Tutorial.Application -newCheckedSecretReader :: SecretReaderConfig -> Logger IO -> IO (SecretReader IO)-newCheckedSecretReader (SecretReaderConfig path) logger = do+newCheckedSecretReader :: MonadIO m => SecretReaderConfig -> Logger IO -> m (SecretReader IO)+newCheckedSecretReader (SecretReaderConfig path) logger = liftIO $ do   exists <- doesFileExist (toS path)-  if not exists then fileDoesNotExist else pure ()+  unless exists fileDoesNotExist   pure     SecretReader       { readSecret =@@ -29,10 +29,10 @@   funTo @IO App     <: funTo @IO newUserInput     <: funTo @IO newRng-    <: funTo @IO newCheckedSecretReader+    <: funTo @IO (newCheckedSecretReader @IO)     <: funTo @IO newLogger     <: funTo @IO newConsole-    <: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt")+    <: valTo @IO (SecretReaderConfig "test/Test/Tutorial/secret.txt")  newAppIO :: IO App newAppIO = make @(IO App) registryIO
test/Test/Tutorial/Exercise6.hs view
@@ -9,10 +9,10 @@ import System.Directory (doesFileExist) import Test.Tutorial.Application -newCheckedSecretReader :: SecretReaderConfig -> Logger IO -> Tag "unchecked" (SecretReader IO) -> IO (SecretReader IO)-newCheckedSecretReader (SecretReaderConfig path) logger uncheckedReader = do+newCheckedSecretReader :: MonadIO m => SecretReaderConfig -> Logger IO -> Tag "unchecked" (SecretReader IO) -> m (SecretReader IO)+newCheckedSecretReader (SecretReaderConfig path) logger uncheckedReader = liftIO $ do   exists <- doesFileExist (toS path)-  if not exists then fileDoesNotExist else pure ()+  unless exists fileDoesNotExist   pure $ unTag uncheckedReader   where     fileDoesNotExist = error logger ("file does not exist at " <> path)@@ -21,12 +21,12 @@ registryIO =   funTo @IO App     <: funTo @IO newUserInput-    <: funTo @IO newCheckedSecretReader+    <: funTo @IO (newCheckedSecretReader @IO)     <: funTo @IO (tag @"unchecked" newSecretReader)     <: funTo @IO newRng     <: funTo @IO newLogger     <: funTo @IO newConsole-    <: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt")+    <: valTo @IO (SecretReaderConfig "test/Test/Tutorial/secret.txt")  newAppIO :: IO App newAppIO = make @(IO App) registryIO
test/Test/Tutorial/Exercise7.hs view
@@ -7,27 +7,22 @@ import Data.Registry import Protolude import Test.Tutorial.Application-import Test.Tutorial.Exercise6 -newInitializedLogger :: IO (Logger IO)-newInitializedLogger = do+-- | This makes sure that there is only one logger ever used in the application+newCachedLogger :: Rio (Logger IO)+newCachedLogger = singleton $ do   print ("start the logger" :: Text)   pure (Logger putStrLn putStrLn) -newInitializedRegistry :: Registry _ _-newInitializedRegistry = fun newInitializedLogger <: registryIO--newInitializedAppIO :: IO App-newInitializedAppIO = make @(IO App) newInitializedRegistry--memoizedRegistry :: IO (Registry _ _)-memoizedRegistry = memoize @IO @(Logger IO) newInitializedRegistry--newInitializedMemoizedAppIO :: IO App-newInitializedMemoizedAppIO = make @(IO App) =<< memoizedRegistry--memoizedAllRegistry :: IO (Registry _ _)-memoizedAllRegistry = memoizeAll @IO newInitializedRegistry+registry :: Registry _ _+registry =+  funTo @Rio App+    <: funTo @Rio newUserInput+    <: funTo @Rio newRng+    <: funTo @Rio newSecretReader+    <: fun newCachedLogger+    <: funTo @Rio newConsole+    <: valTo @Rio (SecretReaderConfig "test/Test/Tutorial/secret.txt") -newInitializedMemoizedAllAppIO :: IO App-newInitializedMemoizedAllAppIO = make @(IO App) =<< memoizedAllRegistry+newAppIO :: IO App+newAppIO = withRegistry @App registry pure