registry 0.1.0.5 → 0.1.1.0

raw patch · 12 files changed

+227/−30 lines, 12 filesdep +MonadRandomdep +random

Dependencies added: MonadRandom, random

Files

• registry.cabal +11/−7
• src/Data/Registry/Internal/Dynamic.hs +9/−1
• src/Data/Registry/Internal/Registry.hs +7/−3
• src/Data/Registry/RIO.hs +0/−2
• src/Data/Registry/Registry.hs +6/−4
• src/Data/Registry/Solver.hs +1/−1
• test/Test/Data/Registry/Internal/Gens.hs +1/−0
• test/Test/Data/Registry/Make.hs +2/−2
• test/Test/Data/Registry/MonadRandomSpec.hs +131/−0
• test/Test/Data/Registry/RegistrySpec.hs +40/−0
• test/Test/Data/Registry/SmallExample.hs +6/−5
• test/Test/Tasty/Extensions.hs +13/−5

@@ -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

@@ -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)

@@ -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

@@ -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))

@@ -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 +:

@@ -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 

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-missing-monadfail-instances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Data.Registry.Internal.Gens where

@@ -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)

@@ -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)

@@ -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)

@@ -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

@@ -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)))