diff --git a/registry.cabal b/registry.cabal --- a/registry.cabal +++ b/registry.cabal @@ -4,11 +4,11 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 4903dda8ecffbd172e77e76e68185073add2022cf8428f52defad78286f52267 +-- hash: ed72935dd76dfeedd16a88cf5a89166e40c882c6bbd693cb2a05f9d2c898c1df name: registry -version: 0.1.1.2 -synopsis: data structure for assembling "components" +version: 0.1.2.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. category: Control @@ -48,6 +48,7 @@ build-depends: base >=4.7 && <5 , exceptions <0.11 + , mtl <3 , protolude <0.3 , resourcet <1.3 , text <2 @@ -85,6 +86,7 @@ , hedgehog <0.7 , hedgehog-corpus <0.2 , io-memoize <1.2 + , mtl <3 , protolude <0.3 , random <2.0 , registry diff --git a/src/Data/Registry.hs b/src/Data/Registry.hs --- a/src/Data/Registry.hs +++ b/src/Data/Registry.hs @@ -8,10 +8,10 @@ module M ) where -import Data.Registry.RIO as M -import Data.Registry.Make as M -import Data.Registry.Registry as M -import Data.Registry.Lift as M -import Data.Registry.Solver as M -import Data.Registry.Warmup as M -import Data.Registry.Dot as M +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.Registry as M -- The Registry data structure +import Data.Registry.RIO as M -- A monad for instantiating components (managing resources, handling startup) +import Data.Registry.Solver as M -- Type-level constraints to check if we can make a component from a registry +import Data.Registry.Warmup as M -- A small DSL for describing the warmup actions of a component diff --git a/src/Data/Registry/Dot.hs b/src/Data/Registry/Dot.hs --- a/src/Data/Registry/Dot.hs +++ b/src/Data/Registry/Dot.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MonoLocalBinds #-} {- | - This modules provides functions to extract + This module provides functions to extract a DOT graph (https://en.wikipedia.org/wiki/DOT_(graph_description_language) out of a 'Registry'. -} diff --git a/src/Data/Registry/Internal/Dynamic.hs b/src/Data/Registry/Internal/Dynamic.hs --- a/src/Data/Registry/Internal/Dynamic.hs +++ b/src/Data/Registry/Internal/Dynamic.hs @@ -29,8 +29,8 @@ pure $ CreatedValue created (ValueDescription (_outputType . funDescription $ function) Nothing) -- | Apply a Dynamic function to a list of Dynamic values -applyFunctionDyn - :: Dynamic -- ^ function +applyFunctionDyn :: + Dynamic -- ^ function -> [Dynamic] -- ^ inputs -> Either Text Dynamic -- ^ result applyFunctionDyn f [] = diff --git a/src/Data/Registry/Internal/Make.hs b/src/Data/Registry/Internal/Make.hs --- a/src/Data/Registry/Internal/Make.hs +++ b/src/Data/Registry/Internal/Make.hs @@ -29,8 +29,11 @@ -- | Make a value from a desired output type represented by SomeTypeRep -- and a list of possible constructors -- A 'Context' is passed in the form of a stack of the types we are trying to build so far -makeUntyped - :: SomeTypeRep +-- Functions is the list of all the constructors in the Registry +-- Specializations is a list of specific values to use in a given context, overriding the normal search +-- Modifiers is a list of functions to apply right before a value is stored in the Registry +makeUntyped :: + SomeTypeRep -> Context -> Functions -> Specializations @@ -52,6 +55,7 @@ if length inputs /= length inputTypes then + -- report an error if we cannot make enough input parameters to apply the function let madeInputTypes = fmap valueDynTypeRep inputs missingInputTypes = inputTypes \\ madeInputTypes in @@ -62,6 +66,7 @@ <> ["could be made. Missing"] <> fmap show missingInputTypes else do + -- else apply the function and store the output value in the registry v <- lift $ applyFunction function inputs modified <- storeValue modifiers v @@ -77,8 +82,8 @@ -- When a value has been made it is placed on top of the -- existing registry so that it is memoized if needed in -- subsequent calls -makeInputs - :: [SomeTypeRep] -- ^ input types to build +makeInputs :: + [SomeTypeRep] -- ^ input types to build -> Context -- ^ current context of types being built -> Functions -- ^ available functions to build values -> Specializations -- ^ list of values to use when in a specific context @@ -103,5 +108,5 @@ -- of what could be eventually made makeInputs ins (Context context) functions specializations modifiers - Just v -> do + Just v -> (v :) <$> makeInputs ins (Context context) functions specializations modifiers diff --git a/src/Data/Registry/Internal/Operations.hs b/src/Data/Registry/Internal/Operations.hs --- a/src/Data/Registry/Internal/Operations.hs +++ b/src/Data/Registry/Internal/Operations.hs @@ -27,6 +27,8 @@ ((out,) <$> ins) <> makeEdges rest +-- * DOT GRAPH + -- | A DOT graph newtype Dot = Dot { unDot :: Text diff --git a/src/Data/Registry/Internal/Reflection.hs b/src/Data/Registry/Internal/Reflection.hs --- a/src/Data/Registry/Internal/Reflection.hs +++ b/src/Data/Registry/Internal/Reflection.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TypeInType #-} {- | - Utility functions to display types + Utility functions to display or manipulate types -} module Data.Registry.Internal.Reflection where diff --git a/src/Data/Registry/Internal/Registry.hs b/src/Data/Registry/Internal/Registry.hs --- a/src/Data/Registry/Internal/Registry.hs +++ b/src/Data/Registry/Internal/Registry.hs @@ -15,18 +15,19 @@ import Protolude as P import Type.Reflection --- | Find a value having a target type --- from a list of dynamic values found in a list of constructors --- where some of them are not functions --- There is also a list of specializations when we can specialize the values to use --- if a given type is part of the context +-- | Find a value having a target type from: +-- - a list of "preferred values" (Specializations) to select when we are trying +-- to find the targe in a specific context (Context). Context describes +-- the types of values we are currently trying to (recursively) make +-- +-- - a list of dynamic values (Values) findValue :: SomeTypeRep -> Context -> Specializations -> Values -> Maybe Value --- no specializations or constructors to choose from +-- no specializations or values to choose from findValue _ _ (Specializations []) (Values []) = Nothing -- recurse on the specializations first diff --git a/src/Data/Registry/Internal/Types.hs b/src/Data/Registry/Internal/Types.hs --- a/src/Data/Registry/Internal/Types.hs +++ b/src/Data/Registry/Internal/Types.hs @@ -13,7 +13,7 @@ import qualified Protolude as P import Type.Reflection --- | A 'Function' is the 'Dynamic' representation of a Haskell value + its description +-- | A 'Value' is the 'Dynamic' representation of a Haskell value + its description -- It is either provided by the user of the Registry or created as part of the -- resolution algorithm data Value = @@ -119,18 +119,18 @@ funDescriptionToText :: FunctionDescription -> Text funDescriptionToText (FunctionDescription ins out) = T.intercalate " -> " (ins <> [out]) --- | Return True if a 'Function' has some input values +-- | Return True if a 'Function' has some input parameters hasParameters :: Function -> Bool hasParameters = isFunction . funDynTypeRep --- | A Typed value can be added to a 'Registry' +-- | A Typed value or function can be added to a 'Registry' -- It is either a value, having both 'Show' and 'Typeable' information -- or a function having just 'Typeable' information data Typed a = TypedValue Value | TypedFunction Function --- | The list of functions available for constructing other values +-- | This is a list of functions (or "constructors") available for constructing values newtype Functions = Functions [Function] deriving (Show, Semigroup, Monoid) -- | Display a list of constructors @@ -145,7 +145,8 @@ addFunction :: Function -> Functions -> Functions addFunction f (Functions fs) = Functions (f : fs) --- | List of values available for constructing other values +-- | List of values available which can be used as parameters to +-- constructors for building other values newtype Values = Values [Value] deriving (Show, Semigroup, Monoid) -- | Display a list of values @@ -160,7 +161,8 @@ addValue :: Value -> Values -> Values addValue v (Values vs) = Values (v : vs) --- | The types of values being currently built +-- | The types of values that we are trying to build at a given moment +-- of the resolution algorithm newtype Context = Context { _context :: [SomeTypeRep] } deriving (Show, Semigroup, Monoid) -- | Specification of values which become available for diff --git a/src/Data/Registry/Make.hs b/src/Data/Registry/Make.hs --- a/src/Data/Registry/Make.hs +++ b/src/Data/Registry/Make.hs @@ -16,11 +16,11 @@ 2. if not found search a function having the desired output type if found, now try to recursively make all the input parameters. - Keep a context of the current type trying to be built. + Keep a stack of the current types trying to be built. 3. when trying to make an input parameter if the current input type is already in the types trying to be built then there is a cycle. - Throw an exception in that case + Return an error in that case 4. when a value has been constructed place it on top of the existing value list so that it can be reused by other functions @@ -42,18 +42,16 @@ -- | For a given registry make an element of type a -- We want to ensure that a is indeed one of the return types -- We also try to statically check if there aren't other possible errors -make - :: forall a ins out - . (Typeable a, Contains a out, Solvable ins out) +make :: forall a ins out . + (Typeable a, Contains a out, Solvable ins out) => Registry ins out -> a make = makeUnsafe -- | Same as make but without the solvable constraint to compile faster -- in tests for example -makeFast - :: forall a ins out - . (Typeable a, Contains a out) +makeFast :: forall a ins out . + (Typeable a, Contains a out) => Registry ins out -> a makeFast = makeUnsafe @@ -71,7 +69,7 @@ -- use the makeUntyped function to create an element of the target type from a list of values and functions -- the list of values is kept as some State so that newly created values can be added to the current state case - (flip runStack) values $ + flip runStack values $ (makeUntyped targetType (Context [targetType]) functions specializations modifiers) of @@ -87,7 +85,7 @@ (Left $ "could not cast the computed value to a " <> show targetType <> ". The value is of type: " <> show (valueDynTypeRep result)) (Right <$> fromDynamic (valueDyn result)) --- | This version of make only execute checks at runtime +-- | This version of `make` only execute checks at runtime -- this can speed-up compilation when writing tests or in ghci makeUnsafe :: forall a ins out . (Typeable a) => Registry ins out -> a makeUnsafe registry = diff --git a/src/Data/Registry/RIO.hs b/src/Data/Registry/RIO.hs --- a/src/Data/Registry/RIO.hs +++ b/src/Data/Registry/RIO.hs @@ -5,15 +5,16 @@ {- | RIO is equivalent to @ResourceT (WriterT Warmup IO)@ - It can be used to instantiate "modules as records of functions" - where each module can allocate resources and have a "warmup phase" - to preload data or asses if it is working properly + It can be used to instantiate "components as records of functions" + where each component can allocate resources and have a "warmup phase" + to preload data or assess if it is working properly. -} module Data.Registry.RIO where import Control.Monad.Base import Control.Monad.Catch +import Control.Monad.Trans import Control.Monad.Trans.Resource import qualified Control.Monad.Trans.Resource as Resource (allocate) @@ -31,93 +32,104 @@ runStop (Stop is) = runResourceT $ closeInternalState is -- | This newtype creates a monad to sequence --- module creation actions, cumulating start/stop tasks +-- component creation actions, cumulating start/stop tasks -- found along the way -newtype RIO a = - RIO - { runRIO :: Stop -> IO (a, Warmup) } + +newtype RioT m a = + RioT + { runRioT :: Stop -> m (a, Warmup) } deriving (Functor) -instance Applicative RIO where +-- | Specialization of RioT to IO +type RIO = RioT IO + +runRIO :: RIO a -> Stop -> IO (a, Warmup) +runRIO = runRioT + +instance (Monad m) => Applicative (RioT m) where pure a = - RIO (const (pure (a, mempty))) + RioT (const (pure (a, mempty))) - RIO fab <*> RIO fa = - RIO $ \s -> + RioT fab <*> RioT fa = + RioT $ \s -> do (f, sf) <- fab s (a, sa) <- fa s pure (f a, sf `mappend` sa) -instance Monad RIO where +instance (Monad m) => Monad (RioT m) where return = pure - RIO ma >>= f = - RIO $ \s -> + RioT ma >>= f = + RioT $ \s -> do (a, sa) <- ma s - (b, sb) <- runRIO (f a) s + (b, sb) <- runRioT (f a) s pure (b, sa `mappend` sb) -instance MonadIO RIO where - liftIO io = RIO (const $ (, mempty) <$> io) +instance (MonadIO m) => MonadIO (RioT m) where + liftIO io = RioT (const $ (, mempty) <$> liftIO io) -instance MonadThrow RIO where - throwM e = RIO (const $ throwM e) +instance (MonadThrow m) => MonadThrow (RioT m) where + throwM e = RioT (const $ throwM e) -instance MonadBase IO RIO where +instance (MonadBase IO m, MonadIO m) => MonadBase IO (RioT m) where liftBase = liftIO -instance MonadResource RIO where - liftResourceT action = RIO $ \(Stop s) -> liftIO ((, mempty) <$> runInternalState action s) +instance MonadResource m => MonadResource (RioT m) where + liftResourceT action = RioT $ \(Stop s) -> liftIO ((, mempty) <$> runInternalState action s) +instance MonadTrans RioT where + lift :: Monad m => m a -> RioT m a + lift ma = RioT (const $ (, mempty) <$> ma) + -- * For production --- | This function must be used to run services involving a top module --- It creates the top module and invokes all warmup functions +-- | This function must be used to run services involving a top component +-- It creates the top component and invokes all warmup functions -- -- The passed function 'f' is used to decide whether to continue or -- not depending on the Result -withRegistry :: forall a b ins out . (Typeable a, Contains (RIO a) out, Solvable ins out) => +withRegistry :: forall a b ins out m . (Typeable a, Typeable m, MonadIO m, MonadUnliftIO m, Contains (RioT m a) out, Solvable ins out) => Registry ins out - -> (Result -> a -> IO b) - -> IO b + -> (Result -> a -> m b) + -> m b withRegistry registry f = runResourceT $ do (a, warmup) <- runRegistryT @a registry - result <- lift $ runWarmup warmup + result <- lift . liftIO $ runWarmup warmup lift $ f result a -- | 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) => Registry ins out -> ResourceT IO (a, Warmup) -runRegistryT registry = withInternalState $ \is -> runRIO (make @(RIO a) registry) (Stop is) +runRegistryT :: forall a ins out m . (Typeable a, Typeable m, MonadIO m, Contains (RioT m a) out, Solvable ins out) => Registry ins out -> ResourceT m (a, Warmup) +runRegistryT registry = withInternalState $ \is -> runRioT (make @(RioT m a) registry) (Stop is) -- * For testing -- | Instantiate the component but don't execute the warmup (it may take time) -- and keep the Stop value to clean resources later -- This function statically checks that the component can be instantiated -executeRegistry :: forall a ins out . (Typeable a, Contains (RIO a) out, Solvable ins out) => Registry ins out -> IO (a, Warmup, Stop) +executeRegistry :: forall a ins out m . (Typeable a, Typeable m, MonadIO m, Contains (RioT m a) out, Solvable ins out) => Registry ins out -> m (a, Warmup, Stop) executeRegistry registry = do - is <- createInternalState - (a, w) <- runRIO (make @(RIO a) registry) (Stop is) + is <- liftIO createInternalState + (a, w) <- runRioT (make @(RioT m a) registry) (Stop is) pure (a, w, Stop is) -- | Instantiate the component but don't execute the warmup (it may take time) and lose a way to cleanu up resources -- | Almost no compilation time is spent on checking that component resolution is possible -unsafeRun :: forall a ins out . (Typeable a, Contains (RIO a) out) => Registry ins out -> IO a +unsafeRun :: forall a ins out m . (Typeable a, Typeable m, MonadIO m, Contains (RioT m a) out) => Registry ins out -> m a unsafeRun registry = fst <$> unsafeRunWithStop registry -- | Same as 'unsafeRun' but keep the 'Stop' value to be able to clean resources later -unsafeRunWithStop :: forall a ins out . (Typeable a, Contains (RIO a) out) => Registry ins out -> IO (a, Stop) +unsafeRunWithStop :: forall a ins out m . (Typeable a, Typeable m, MonadIO m, Contains (RioT m a) out) => Registry ins out -> m (a, Stop) unsafeRunWithStop registry = do is <- createInternalState - (a, _) <- runRIO (makeUnsafe @(RIO a) registry) (Stop is) + (a, _) <- runRioT (makeUnsafe @(RioT m a) registry) (Stop is) pure (a, Stop is) --- | Lift a 'Warmup' action into the 'RIO' monad -warmupWith :: Warmup -> RIO () -warmupWith w = RIO (const $ pure ((), w)) +-- | Lift a 'Warmup' action into the 'RioT m' monad +warmupWith :: (Applicative m) => Warmup -> RioT m () +warmupWith w = RioT (const $ pure ((), w)) -- | Allocate some resource -allocate :: IO a -> (a -> IO ()) -> RIO a +allocate :: (MonadResource m) => IO a -> (a -> IO ()) -> RioT m a allocate resource cleanup = snd <$> Resource.allocate resource cleanup diff --git a/src/Data/Registry/Registry.hs b/src/Data/Registry/Registry.hs --- a/src/Data/Registry/Registry.hs +++ b/src/Data/Registry/Registry.hs @@ -27,22 +27,7 @@ At the type level a list of all the function inputs and all the outputs is being kept to allow some checks to be made when we want to build a value out of the registry. - Registries have a `Monoid` instance so they can be created incrementally: - - > config = - > val (Config 1) - > +: val "hello" - > +: end - > - > constructors = - > +: fun add1 - > +: fun show1 - > +: end - > - > registry = - > config <> constructors - - It is also possible to use the `<+>` operator to "override" some configurations: + It is possible to use the `<+>` operator to "override" some configurations: > mocks = > fun noLogging @@ -89,7 +74,7 @@ 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))) + 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 []) @@ -204,6 +189,7 @@ modifiers -- | Once a value has been computed allow to modify it before storing it +-- This keeps the same registry type tweak :: forall a ins out . (Typeable a, Contains a out) => (a -> a) -> Registry ins out diff --git a/src/Data/Registry/Solver.hs b/src/Data/Registry/Solver.hs --- a/src/Data/Registry/Solver.hs +++ b/src/Data/Registry/Solver.hs @@ -48,8 +48,9 @@ -- | Extracted from the typelevel-sets project and adapted for the Registry datatype --- | This union deduplicates elements only --- if they appear in contiguously: +-- This union deduplicates elements only if they appear in contiguously +-- What we really want is typelevel sets but they are too slow for now +-- https://github.com/dorchard/type-level-sets/issues/17 type family (:++) (x :: [k]) (y :: [k]) :: [k] where '[] :++ xs = xs (x ': xs) :++ ys = x ': (xs :++ ys) diff --git a/src/Data/Registry/Warmup.hs b/src/Data/Registry/Warmup.hs --- a/src/Data/Registry/Warmup.hs +++ b/src/Data/Registry/Warmup.hs @@ -27,8 +27,8 @@ -- * Creation functions --- | Create a warmup action for a given module --- The type of the module is used as the description for +-- | Create a warmup action for a given component +-- The type of the component is used as the description for -- the action to execute warmupOf :: Typeable a => a -> IO () -> Warmup warmupOf a action = createWarmup $ diff --git a/test/Test/Data/Registry/Internal/Gens.hs b/test/Test/Data/Registry/Internal/Gens.hs --- a/test/Test/Data/Registry/Internal/Gens.hs +++ b/test/Test/Data/Registry/Internal/Gens.hs @@ -14,6 +14,7 @@ import Protolude import Type.Reflection +-- Hedgehog generators for the internal types registry = funTo @Gen UntypedRegistry +: funTo @Gen Values diff --git a/test/Test/Data/Registry/Internal/ReflectionSpec.hs b/test/Test/Data/Registry/Internal/ReflectionSpec.hs --- a/test/Test/Data/Registry/Internal/ReflectionSpec.hs +++ b/test/Test/Data/Registry/Internal/ReflectionSpec.hs @@ -36,7 +36,7 @@ valDescriptionToText (describeValue (Right 1 :: Either Text Int)) === "Either (Text Int): Right 1" valDescriptionToText (describeValue ([1] :: [Int]) ) === "[Int]: [1]" - -- user types must be shown with their full module names + -- user types must be shown with their full component names valDescriptionToText (describeValue mod1) === "Test.Data.Registry.Internal.ReflectionSpec.Mod Int: Mod 1 \"hey\"" test_show_function = test "show simple functions" $ do diff --git a/test/Test/Data/Registry/Make.hs b/test/Test/Data/Registry/Make.hs --- a/test/Test/Data/Registry/Make.hs +++ b/test/Test/Data/Registry/Make.hs @@ -24,7 +24,7 @@ +: fun newUseConfig2 +: end let r' = specialize @UseConfig1 (Config 1) $ - specialize @UseConfig2 (Config 2) $ r + specialize @UseConfig2 (Config 2) r pure (printConfig1 (make @UseConfig1 r'), printConfig2 (make @UseConfig2 r')) c1 === Config 1 @@ -127,7 +127,7 @@ Left (_ :: SomeException) -> assert True Right _ -> assert False --- | A regular module can be made without having an explicit Typeable constraint +-- | No typeclass instance is necessary for a "record of functions" to be a Registry component data Logging = Logging { info :: Text -> IO () , debug :: Text -> IO () @@ -168,7 +168,7 @@ countSize :: Text -> Maybe Int countSize t = Just (T.length t) -m = make @Text $ (fun $ \(t::Text) -> t) +: end +m = make @Text $ fun (\(t::Text) -> t) +: end made1 :: Text made1 = make @Text registry1 diff --git a/test/Test/Data/Registry/MonadRandomSpec.hs b/test/Test/Data/Registry/MonadRandomSpec.hs --- a/test/Test/Data/Registry/MonadRandomSpec.hs +++ b/test/Test/Data/Registry/MonadRandomSpec.hs @@ -5,11 +5,11 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {- - This module shows how to define a Module filling in + This module shows how to define a component filling in the role of a typeclass as required by another library. For example you might use a library requiring `MonadRandom`. - How can you define a `RandomGenerator` module letting you use your library? + How can you define a `RandomGenerator` component letting you use your library? -} module Test.Data.Registry.MonadRandomSpec where @@ -24,30 +24,30 @@ -- Let's say you have this function coming from a library -- It has a MonadRandom constraint but you would like to create a --- module supporting the generation of random number and you +-- component supporting the generation of random number and you -- would like to be able to use it to call such a function useMonadRandom :: R.MonadRandom m => m Int useMonadRandom = R.getRandom --- For example this ClientModule might require for its implementation +-- For example this Client component might require for its implementation -- the `useMonadRandomFunction` -data ClientModule = ClientModule { runClient :: IO Int } +newtype Client = Client { runClient :: IO Int } --- | What we see here is that the ClientModule can be implemented --- with a RandomGenerator module which will provide a way to call +-- | What we see here is that the Client component can be implemented +-- with a RandomGenerator component which will provide a way to call -- the library function having the MonadRandom constraint -newClientModule :: RandomGenerator -> ClientModule -newClientModule RandomGenerator {..} = ClientModule { +newClient :: RandomGenerator -> Client +newClient RandomGenerator {..} = Client { runClient = runRandom useMonadRandom } --- This is the RandomGenerator module +-- This is the RandomGenerator component -- it reuses the RandT monad which "implements" MonadRandom given a specific generator -- it is defined for a given RandomGen type which we don't need to expose data RandomGenerator = forall g . RandomGen g => RandomGenerator { runRandom :: forall a . RandT g IO a -> IO a } --- | Production Random generator module using the global StdGen +-- | Production Random generator component using the global StdGen newRandomGenerator :: IO RandomGenerator newRandomGenerator = newStdGen >>= makeRandomGenerator @@ -86,13 +86,13 @@ -- | The registry to use for production looks like this -- It uses the global StdGen registryProd = - funTo @IO newClientModule + funTo @IO newClient +: fun newRandomGenerator +: end -- | And now some tests -test_client_function_with_random_values = test "a function using MonadRandom can be executed with the RandomGenerator module and return random values" $ do - client <- liftIO $ make @(IO ClientModule) registryProd +test_client_function_with_random_values = test "a function using MonadRandom can be executed with the RandomGenerator component and return random values" $ do + client <- liftIO $ make @(IO Client) registryProd results <- liftIO $ replicateM 10 $ client & runClient annotateShow results @@ -100,12 +100,12 @@ -- if we call the generator several times we should get at least 2 different values assert (length (nub results) > 2) -test_client_function_with_seeded_values = test "a function using MonadRandom can be executed with the RandomGenerator module and return predetermined values" $ do +test_client_function_with_seeded_values = test "a function using MonadRandom can be executed with the RandomGenerator component and return predetermined values" $ do let registry' = funAs @IO (newSeededRandomGenerator (RandomGeneratorConfig 1)) +: registryProd - client <- liftIO $ make @(IO ClientModule) registry' + client <- liftIO $ make @(IO Client) registry' results <- liftIO $ replicateM 10 $ client & runClient annotateShow results @@ -113,12 +113,12 @@ -- everytime we call the generator we get different values but the same list take 3 results === [7918028818325808681, 3944251743029676875, 4139876178697185090] -test_client_function_with_fixed_values = test "a function using MonadRandom can be executed with the RandomGenerator module can return always the same value" $ do +test_client_function_with_fixed_values = test "a function using MonadRandom can be executed with the RandomGenerator component can return always the same value" $ do let registry' = funTo @IO (newFixedRandomGenerator (RandomGeneratorConfig 1)) +: registryProd - client <- liftIO $ make @(IO ClientModule) registry' + client <- liftIO $ make @(IO Client) registry' results <- liftIO $ replicateM 10 $ client & runClient annotateShow results diff --git a/test/Test/Data/Registry/SmallExample.hs b/test/Test/Data/Registry/SmallExample.hs --- a/test/Test/Data/Registry/SmallExample.hs +++ b/test/Test/Data/Registry/SmallExample.hs @@ -17,6 +17,10 @@ import Test.Tasty.Extensions -- | Components of the application +-- - a Logger +-- - an interface to S3 +-- - a lines counter +-- - the top level application newtype Logger = Logger { info :: Text -> IO () } deriving Typeable @@ -52,7 +56,7 @@ } deriving Typeable newApplication :: MonadIO m => Logger -> LinesCounter -> S3 -> m Application -newApplication (Logger {..}) (LinesCounter {..}) (S3 {..}) = pure $ Application $ \t -> do +newApplication Logger {..} LinesCounter {..} S3 {..} = pure . Application $ \t -> do info "count lines" let n = count t @@ -64,9 +68,9 @@ registry = funAs @IO (newS3 @IO) +: funAs @IO (newApplication @IO) - +: funTo @IO newLogger - +: funTo @IO newLinesCounter - +: valTo @IO (S3Config "bucket" "key") + +: funTo @IO newLogger + +: funTo @IO newLinesCounter + +: valTo @IO (S3Config "bucket" "key") +: end -- | To create the application you call `make` for the `Application` type @@ -77,7 +81,7 @@ createApplication = make @(IO Application) (funTo @IO noLogging +: registry) test_create = test "create the application" $ do - app <- liftIO $ createApplication -- nothing should crash! + app <- liftIO createApplication -- nothing should crash! r <- liftIO $ (app & run) "hello\nworld" r === 2 diff --git a/test/Test/Data/Registry/WarmupSpec.hs b/test/Test/Data/Registry/WarmupSpec.hs --- a/test/Test/Data/Registry/WarmupSpec.hs +++ b/test/Test/Data/Registry/WarmupSpec.hs @@ -12,7 +12,7 @@ import Data.Registry.Warmup test_runBoth1 = - prop "all results are collected when running 2 start/stop tasks" $ do + prop "all results are collected when running 2 warmup tasks" $ do r1 <- forAll genResult r2 <- forAll genResult r <- liftIO $ pure r1 `runBoth` pure r2