diff --git a/registry.cabal b/registry.cabal --- a/registry.cabal +++ b/registry.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 1ca0ac117d7f1e1ba6f55c94a7f3823951cf78d4e19ef293fbd0d3afc61142af +-- hash: a6b0a84be53407fd0d0dfd4cd14b966f573fc2925fdd6fb561542e4e93f26676 name: registry -version: 0.1.0.5 +version: 0.1.1.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. @@ -42,8 +42,8 @@ Paths_registry hs-source-dirs: src - default-extensions: FlexibleContexts FlexibleInstances LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings Rank2Types ScopedTypeVariables ScopedTypeVariables TupleSections TypeApplications TypeOperators - ghc-options: -Wall -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path + default-extensions: BangPatterns DefaultSignatures EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms Rank2Types RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns build-depends: base >=4.7 && <5 , exceptions <0.11 @@ -65,22 +65,26 @@ Test.Data.Registry.Internal.ReflectionSpec Test.Data.Registry.Internal.RegistrySpec Test.Data.Registry.Make + Test.Data.Registry.MonadRandomSpec + Test.Data.Registry.RegistrySpec Test.Data.Registry.SmallExample Test.Data.Registry.WarmupSpec Test.Tasty.Extensions Paths_registry hs-source-dirs: test - default-extensions: FlexibleContexts FlexibleInstances LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings Rank2Types ScopedTypeVariables ScopedTypeVariables TupleSections TypeApplications TypeOperators - ghc-options: -Wall -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures -optP-Wno-nonportable-include-path + default-extensions: BangPatterns DefaultSignatures EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms Rank2Types RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures -fno-warn-incomplete-uni-patterns -optP-Wno-nonportable-include-path build-depends: - async <2.3 + MonadRandom <0.6 + , async <2.3 , base >=4.7 && <5 , exceptions <0.11 , hedgehog <0.7 , hedgehog-corpus <0.2 , io-memoize <1.2 , protolude <0.3 + , random <2.0 , registry , resourcet <1.3 , tasty <1.2 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 @@ -8,7 +8,7 @@ import Data.Dynamic import Data.Registry.Internal.Types import Data.Text -import Protolude +import Protolude as P import Type.Reflection -- | Apply a function to a list of 'Dynamic' values @@ -16,6 +16,14 @@ Function -- ^ function -> [Value] -- ^ inputs -> Either Text Value -- ^ result +applyFunction function [] = + if P.null (collectInputTypes function) then + pure $ CreatedValue (funDyn function) (ValueDescription (_outputType . funDescription $ function) Nothing) + else + Left $ "the function " + <> show (dynTypeRep (funDyn function)) + <> " cannot be applied to an empty list of parameters" + applyFunction function values = do created <- applyFunctionDyn (funDyn function) (valueDyn <$> values) pure $ CreatedValue created (ValueDescription (_outputType . funDescription $ function) Nothing) 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 @@ -47,7 +47,7 @@ findValue target context specializations (Values rest) -- | Find a constructor function returning a target type --- from a list of constructorsfe +-- from a list of constructors findConstructor :: SomeTypeRep -> Functions @@ -61,8 +61,12 @@ else findConstructor target (Functions rest) - _ -> - findConstructor target (Functions rest) + -- a "function" with no arguments + SomeTypeRep out -> + if outputType (SomeTypeRep out) == target then + Just f + else + findConstructor target (Functions rest) -- | Given a newly built value, check if there are modifiers for that -- value and apply them before "storing" the value which means 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 @@ -113,8 +113,6 @@ (a, _) <- runRIO (makeUnsafe @(RIO a) registry) (Stop is) pure (a, Stop is) --- * Module creation - -- | Lift a 'Warmup' action into the 'RIO' monad warmupWith :: Warmup -> RIO () warmupWith w = RIO (const $ pure ((), w)) 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 @@ -88,6 +88,11 @@ in toS $ unlines [describeValues, describeFunctions] +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 = (<>) @@ -108,10 +113,7 @@ Registry (Values (v : vs)) functions specializations modifiers register (TypedFunction f) (Registry (Values vs) (Functions fs) specializations modifiers) = - if hasParameters f then - Registry (Values vs) (Functions (f : fs)) specializations modifiers - else - Registry (Values (createDynValue (funDyn f) (showFunction f) : vs)) (Functions fs) specializations modifiers + Registry (Values vs) (Functions (f : fs)) specializations modifiers -- | Add an element to the Registry - Alternative to register where the parentheses can be ommitted infixr 5 +: 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 @@ -28,7 +28,7 @@ -- | Compute if a type is contained in a list of types type family Contains (a :: *) (els :: [*]) :: Constraint where - Contains a '[] = TypeError ('Text "No element of type " ':<>: 'ShowType a ':<>: 'Text " can be build out of the registry") + Contains a '[] = TypeError ('Text "No element of type " ':<>: 'ShowType a ':<>: 'Text " can be built out of the registry") Contains a (a ': els) = () Contains a (b ': els) = Contains a els 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 @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-missing-monadfail-instances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Test.Data.Registry.Internal.Gens where 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 @@ -128,12 +128,12 @@ Right _ -> assert False -- | A regular module can be made without having an explicit Typeable constraint -data LoggingModule = LoggingModule { +data Logging = Logging { info :: Text -> IO () , debug :: Text -> IO () } -loggingModule = make @LoggingModule (fun LoggingModule { info = print, debug = print } +: end) +logging = make @Logging (fun Logging { info = print, debug = print } +: end) -- | Simple datatypes which can be used in a registry newtype Text1 = Text1 Text deriving (Eq, Show) diff --git a/test/Test/Data/Registry/MonadRandomSpec.hs b/test/Test/Data/Registry/MonadRandomSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/MonadRandomSpec.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +{- + This module shows how to define a Module 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? +-} +module Test.Data.Registry.MonadRandomSpec where + +import Control.Monad.Random.Class as R +import Control.Monad.Trans.Random.Lazy +import Data.IORef +import Data.List +import Data.Registry +import Protolude as P +import System.Random as R +import Test.Tasty.Extensions + +-- 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 +-- 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 +-- the `useMonadRandomFunction` +data ClientModule = ClientModule { 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 +-- the library function having the MonadRandom constraint +newClientModule :: RandomGenerator -> ClientModule +newClientModule RandomGenerator {..} = ClientModule { + runClient = runRandom useMonadRandom +} +-- This is the RandomGenerator module +-- 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 +newRandomGenerator :: IO RandomGenerator +newRandomGenerator = newStdGen >>= makeRandomGenerator + +-- | Random generation is "stateful" in the sense that you get a new +-- generator each time you generate a random value. +-- In this implementation we store this generator with a hidden IORef +-- (which probably be an MVar if we use the RandomGenerator concurrently) +makeRandomGenerator :: (RandomGen g) => g -> IO RandomGenerator +makeRandomGenerator gen = do + ref <- newIORef gen + pure $ RandomGenerator (\a -> + do g <- readIORef ref + (r, g') <- runRandT a g + _ <- writeIORef ref g' + pure r) + +-- * We can now define other ways to generate random values + +-- | Configuration for generators returning pre-determined values +data RandomGeneratorConfig = RandomGeneratorConfig { + seed :: Int +} deriving (Eq, Show) + +-- | All the values for this generator are deterministic and determined by +-- the seed in the configuration +newSeededRandomGenerator :: RandomGeneratorConfig -> IO RandomGenerator +newSeededRandomGenerator (RandomGeneratorConfig aSeed) = do + makeRandomGenerator (mkStdGen aSeed) + +-- | There is only one value for this generator determined by +-- the seed in the configuration +newFixedRandomGenerator :: RandomGeneratorConfig -> RandomGenerator +newFixedRandomGenerator (RandomGeneratorConfig aSeed) = + RandomGenerator ((fst <$>) . flip runRandT (mkStdGen aSeed)) + +-- | The registry to use for production looks like this +-- It uses the global StdGen +registryProd = + funTo @IO newClientModule + +: 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 + results <- liftIO $ replicateM 10 $ client & runClient + + annotateShow results + + -- 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 + let registry' = + funAs @IO (newSeededRandomGenerator (RandomGeneratorConfig 1)) + +: registryProd + + client <- liftIO $ make @(IO ClientModule) registry' + results <- liftIO $ replicateM 10 $ client & runClient + + annotateShow results + + -- 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 + let registry' = + funTo @IO (newFixedRandomGenerator (RandomGeneratorConfig 1)) + +: registryProd + + client <- liftIO $ make @(IO ClientModule) registry' + results <- liftIO $ replicateM 10 $ client & runClient + + annotateShow results + + -- everytime we call the generator we get the same value + length (nub results) === 1 + + +---- +tests = $(testGroupGenerator) diff --git a/test/Test/Data/Registry/RegistrySpec.hs b/test/Test/Data/Registry/RegistrySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/RegistrySpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Test.Data.Registry.RegistrySpec where + +import Data.IORef +import Data.Registry +import Protolude as P +import Test.Tasty.Extensions + +test_create_value_with_no_args_constructor = prop "no args constructors are considered as functions" $ do + ref <- liftIO $ newIORef ("" :: Text) + let registry' = funTo @IO ref +: funTo @IO refLogger +: registry + + Logger {..} <- liftIO $ make @(IO Logger) registry' + liftIO $ info "hey" + + result <- liftIO $ readIORef ref + result === "hey" + +-- * + +newtype Logger = Logger { info :: Text -> IO () } + +newLogger :: IO Logger +newLogger = pure (Logger print) + +refLogger :: IORef Text -> Logger +refLogger ref = Logger (\t -> writeIORef ref t) + +registry = + fun newLogger + +: end + +---- +tests = $(testGroupGenerator) 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 @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} @@ -51,12 +52,12 @@ } deriving Typeable newApplication :: MonadIO m => Logger -> LinesCounter -> S3 -> m Application -newApplication logger counter s3 = pure $ Application $ \t -> do - (logger & info) "count lines" - let n = (counter & count) t +newApplication (Logger {..}) (LinesCounter {..}) (S3 {..}) = pure $ Application $ \t -> do + info "count lines" + let n = count t - (logger & info) "store the lines on s3" - (s3 & store) ("counted " <> P.show n <> " lines") + info "store the lines on s3" + store ("counted " <> P.show n <> " lines") pure n -- | Create a registry for all constructors diff --git a/test/Test/Tasty/Extensions.hs b/test/Test/Tasty/Extensions.hs --- a/test/Test/Tasty/Extensions.hs +++ b/test/Test/Tasty/Extensions.hs @@ -17,17 +17,22 @@ module Hedgehog , module Tasty , gotException +, noShrink , prop , test , minTestsOk +, withSeed ) where +import Data.Maybe (fromJust) import GHC.Stack import Hedgehog as Hedgehog hiding (test) import Hedgehog.Corpus as Hedgehog import Hedgehog.Gen as Hedgehog hiding (discard, print) +import qualified Prelude as Prelude import Protolude hiding ((.&.)) import Test.Tasty as Tasty +import Test.Tasty.Options as Tasty import Test.Tasty.Hedgehog as Tasty import Test.Tasty.TH as Tasty @@ -37,8 +42,7 @@ -- | Create a Tasty test from a Hedgehog property called only once test :: HasCallStack => TestName -> PropertyT IO () -> [TestTree] -test name p = withFrozenCallStack $ - minTestsOk 1 . localOption (HedgehogShrinkLimit (Just (0 :: ShrinkLimit))) <$> prop name p +test name p = withFrozenCallStack (minTestsOk 1 . noShrink $ prop name p) gotException :: forall a . (HasCallStack, Show a) => a -> PropertyT IO () gotException a = withFrozenCallStack $ do @@ -47,9 +51,13 @@ Left _ -> assert True Right _ -> annotateShow ("excepted an exception" :: Text) >> assert False +-- * Parameters +minTestsOk :: Int -> [TestTree] -> [TestTree] +minTestsOk n = fmap (localOption (HedgehogTestLimit (Just (toEnum n :: TestLimit)))) --- * Parameters +noShrink :: [TestTree] -> [TestTree] +noShrink = fmap (localOption (HedgehogShrinkLimit (Just (0 :: ShrinkLimit)))) -minTestsOk :: Int -> (TestTree -> TestTree) -minTestsOk n = localOption (HedgehogTestLimit (Just (fromInteger (toInteger n)))) +withSeed :: Prelude.String -> [TestTree] -> [TestTree] +withSeed seed = fmap (localOption (fromJust (parseValue seed :: Maybe HedgehogReplay)))