registry 0.1.3.4 → 0.1.3.5

raw patch · 10 files changed

+212/−125 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• registry.cabal +3/−2
• src/Data/Registry/Internal/Cache.hs +19/−14
• src/Data/Registry/Internal/Registry.hs +3/−3
• src/Data/Registry/Internal/Types.hs +23/−7
• src/Data/Registry/Registry.hs +4/−3
• test/Test/Data/Registry/Internal/CacheSpec.hs +1/−1
• test/Test/Data/Registry/Internal/Gens.hs +12/−91
• test/Test/Data/Registry/Internal/GensRegistry.hs +103/−0
• test/Test/Data/Registry/Internal/RegistrySpec.hs +5/−4
• test/Test/Data/Registry/Make/SpecializationSpec.hs +39/−0

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 4d59f3f6be3e2768719ac89b179d8b53dc82f0609fc6d3f8f5dbdde8a8e7c223+-- hash: cbbe4d160e44dac16179f493abbb7d0c83446f5ccd2bfe031502caf6091dd958  name:           registry-version:        0.1.3.4+version:        0.1.3.5 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.@@ -73,6 +73,7 @@       Test.Data.Registry.Internal.CacheSpec       Test.Data.Registry.Internal.DynamicSpec       Test.Data.Registry.Internal.Gens+      Test.Data.Registry.Internal.GensRegistry       Test.Data.Registry.Internal.MakeSpec       Test.Data.Registry.Internal.ReflectionSpec       Test.Data.Registry.Internal.RegistrySpec

@@ -8,30 +8,35 @@ -} module Data.Registry.Internal.Cache where -import           Data.Typeable           (Typeable)-import           Protolude as P+import           Data.Map.Strict+import           Data.Registry.Internal.Types (SpecializationPath)+import           Data.Typeable                (Typeable)+import           Protolude                    as P  -- | 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 (Maybe a))+newtype Cache a = Cache (MVar (Map Key a))   deriving (Eq, Typeable) +-- | 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]+ -- | 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) => Cache a -> m a -> m a-fetch (Cache var) action =+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 m of-       Just a -> pure a+     case lookup key m of+        Just a ->+          pure a -       Nothing -> do-         val <- action-         liftIO $ modifyMVar_ var (\_ -> pure (Just val))-         pure val+        Nothing -> do+          val <- action+          liftIO $ modifyMVar_ var (\cached -> pure $ insert key val cached)+          pure val  -- | Create an empty cache. newCache :: IO (Cache a)-newCache = do-  var <- P.newMVar Nothing-  return (Cache var)+newCache = Cache <$> P.newMVar mempty

@@ -49,7 +49,7 @@        compatibleValue = findCompatibleCreatedValue target specializations values -  in bestSpecializedValue <|> compatibleValue+  in  bestSpecializedValue <|> compatibleValue  -- | Among all the applicable specializations take the most specific one --   if there exists any@@ -123,8 +123,8 @@     findModifiers = filter (\(m, _) -> valueDynTypeRep value == m)      -- apply a list of modifiers to a value-    modifyValue :: Value -> [(SomeTypeRep, Function)] -> Stack Value+    modifyValue :: Value -> [(SomeTypeRep, ModifierFunction)] -> Stack Value     modifyValue v [] = pure v     modifyValue v ((_, f) : rest) = do-      applied <- lift $ applyModification f v+      applied <- lift $ applyModification (f (specializationPaths v)) v       modifyValue applied rest

@@ -34,7 +34,6 @@   hash value = hash (valDescription value)   hashWithSalt n value = hashWithSalt n (valDescription value) --- | This registers the specific context in which a valu -- | Description of a value. It might just have --   a description for its type when it is a value --   created by the resolution algorithm@@ -135,10 +134,10 @@ data Function = Function Dynamic FunctionDescription deriving (Show)  -- | Create a 'Function' value from a Haskell function-createFunction :: (Typeable a) => a -> Function-createFunction a =-  let dynType = toDyn a-  in  Function dynType (describeFunction a)+createFunction :: (Typeable f) => f -> Function+createFunction f =+  let dynType = toDyn f+  in  Function dynType (describeFunction f)  -- | Description of a 'Function' with input types and output type data FunctionDescription = FunctionDescription {@@ -258,10 +257,18 @@ --   if that repository is necessary to create a PaymentEngine, itself --   involved in the creation of the App data Specialization = Specialization {-  _specializationPath  :: NonEmpty SomeTypeRep+  _specializationPath  :: SpecializationPath , _specializationValue :: Value } deriving (Show) +type SpecializationPath = NonEmpty SomeTypeRep++specializationPaths :: Value -> Maybe [SpecializationPath]+specializationPaths v =+  case catMaybes $ usedSpecialization <$> (v : (unDependencies . valDependencies $ v)) of+    [] -> Nothing+    ss -> Just (_specializationPath <$> ss)+ -- | First type of a specialization specializationStart :: Specialization -> SomeTypeRep specializationStart = NonEmpty.head . _specializationPath@@ -346,7 +353,16 @@ -- | List of functions modifying some values right after they have been --   built. This enables "tweaking" the creation process with slightly --   different results. Here SomeTypeRep is the target value type 'a' and-newtype Modifiers = Modifiers [(SomeTypeRep, Function)] deriving (Show, Semigroup, Monoid)+newtype Modifiers = Modifiers [(SomeTypeRep, ModifierFunction)] deriving (Semigroup, Monoid)++type ModifierFunction = Maybe [SpecializationPath] -> Function++-- | Create a 'Function' value from a Haskell function+createConstModifierFunction :: (Typeable f) => f -> ModifierFunction+createConstModifierFunction f = const (createFunction f)++instance Show Modifiers where+  show = toS . describeModifiers  -- | Display a list of modifiers for the Registry, just showing the --   type of the modified value

@@ -266,7 +266,7 @@   -> Registry ins out   -> Registry ins out tweakUnsafe f (Registry values functions specializations (Modifiers mf)) = Registry values functions specializations-  (Modifiers ((someTypeRep (Proxy :: Proxy a), createFunction f) : mf))+  (Modifiers ((someTypeRep (Proxy :: Proxy a), createConstModifierFunction f) : mf))  -- * Memoization @@ -287,9 +287,10 @@ memoizeUnsafe :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a))   => Registry ins out   -> IO (Registry ins out)-memoizeUnsafe r = do+memoizeUnsafe (Registry values functions specializations (Modifiers mf)) = do   cache <- newCache @a-  pure $ tweakUnsafe @(m a) (fetch cache) r+  let modifiers = Modifiers ((someTypeRep (Proxy :: Proxy (m a)), \key -> createFunction (fetch @a @m cache key)) : mf)+  pure $ Registry values functions 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

@@ -15,7 +15,7 @@     cache <- newCache      -- when the action is cached it will always return the same value-    let cachedAction = fetch cache action+    let cachedAction = fetch cache Nothing action     void $ replicateConcurrently_ 100 cachedAction -- with concurrent accesses     cachedAction 

@@ -1,103 +1,24 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell       #-}+ {-# OPTIONS_GHC -fno-warn-missing-monadfail-instances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}  module Test.Data.Registry.Internal.Gens where -import           Data.Dynamic import           Data.Registry-import           Data.Registry.Internal.Types-import           Data.Text                         as T+import           Data.Registry.TH import           Hedgehog-import           Hedgehog.Gen                      as Gen-import           Hedgehog.Range                    as Range-import           Prelude                           (show) import           Protolude-import           Type.Reflection-import           Data.List.NonEmpty+import           Test.Data.Registry.Internal.GensRegistry  -- Hedgehog generators for the internal types-registry =-     funTo @Gen UntypedRegistry-  +: funTo @Gen Values-  +: funTo @Gen Functions-  +: funTo @Gen Specializations-  +: funTo @Gen Modifiers-  +: funTo @Gen Context-  +: funTo @Gen Function-  +: funTo @Gen ProvidedValue-  +: funTo @Gen ValueDescription-  +: funTo @Gen FunctionDescription-  +: funTo @Gen Specialization-  +: fun   (genNonEmpty @SomeTypeRep)-  +: fun   (genList @(SomeTypeRep, Function))-  +: fun   (genList @Specialization)-  +: fun   (genPair @SomeTypeRep @Function)-  +: fun   (genPair @(NonEmpty SomeTypeRep) @Value)-  +: fun   (genList @Function)-  +: fun   (genList @SomeTypeRep)-  +: fun   (genList @Value)-  +: fun   (genList @Function)-  +: fun   (genMaybe @Text)-  +: fun   (genList @Text)-  +: fun   genInt-  +: fun   genText-  +: fun   genTextToInt-  +: fun   genDynamic-  +: fun   genSomeTypeRep-  +: end---- * generators-newtype TextToInt = TextToInt (Text -> Int)-instance Show TextToInt where show _ = "<function>"-instance Eq TextToInt where _ == _ = True--genTextToInt :: Gen TextToInt-genTextToInt = pure (TextToInt T.length)--data UntypedRegistry = UntypedRegistry {-    _uvalues          :: Values-  , _ufunctions       :: Functions-  , _uspecializations :: Specializations-  , _umodifiers       :: Modifiers-  } deriving (Show)--genValues :: Gen (Int, Values)-genValues = do-  value  <- gen @Int-  values <- (createValue value `addValue`) <$> gen @Values-  pure (value, values)--genSomeTypeRep :: Gen Value -> Gen SomeTypeRep-genSomeTypeRep = fmap valueDynTypeRep--genDynamic :: Gen Dynamic-genDynamic = Gen.element [toDyn (1 :: Int), toDyn (2 :: Int), toDyn ("1" :: Text)]--forall :: forall a . (Typeable a, Show a) => PropertyT IO a-forall = forAll $ makeUnsafe @(Gen a) registry--genList :: forall a . Gen a -> Gen [a]-genList = Gen.list (Range.linear 1 3)--genNonEmpty :: forall a . Gen a -> Gen (NonEmpty a)-genNonEmpty genA = do-  ls <- Gen.list (Range.linear 1 3) genA-  case ls of-    -- this case can not happen-    [] -> pure <$> genA-    as -> pure (fromList as)--genMaybe :: forall a . Gen a -> Gen (Maybe a)-genMaybe = Gen.maybe--genPair :: forall a b . Gen a -> Gen b -> Gen (a, b)-genPair gena genb = (,) <$> gena <*> genb--genInt :: Gen Int-genInt = Gen.int (Range.linear 0 5)+registry = $(checkRegistry 'gensRegistry) -gen :: forall a . (Typeable a) => Gen a-gen = makeUnsafe registry+forall :: forall a . _ => PropertyT IO a+forall = forAll $ gen @a -genText :: Gen Text-genText = Gen.text (Range.linear 2 10) Gen.alphaNum+gen :: forall a . _ => Gen a+gen = makeFast registry

@@ -0,0 +1,103 @@+{-# OPTIONS_GHC -fno-warn-missing-monadfail-instances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.Internal.GensRegistry where++import           Data.Dynamic+import           Data.List.NonEmpty+import           Data.Registry+import           Data.Registry.Internal.Types+import           Data.Text                    as T+import           Hedgehog+import           Hedgehog.Gen                 as Gen+import           Hedgehog.Range               as Range+import           Prelude                      (show)+import           Protolude+import           Type.Reflection++-- Hedgehog generators for the internal types+gensRegistry =+     funTo @Gen UntypedRegistry+  +: funTo @Gen Values+  +: funTo @Gen Functions+  +: fun genModifierFunction+  +: funTo @Gen Specializations+  +: funTo @Gen Modifiers+  +: funTo @Gen Context+  +: funTo @Gen Function+  +: funTo @Gen ProvidedValue+  +: funTo @Gen ValueDescription+  +: funTo @Gen FunctionDescription+  +: funTo @Gen Specialization+  +: fun   (genNonEmpty @SomeTypeRep)+  +: fun   (genList @Specialization)+  +: fun   (genList @(SomeTypeRep, ModifierFunction))+  +: fun   (genPair @SomeTypeRep @ModifierFunction)+  +: fun   (genPair @(NonEmpty SomeTypeRep) @Value)+  +: fun   (genList @Function)+  +: fun   (genList @SomeTypeRep)+  +: fun   (genList @Value)+  +: fun   (genList @Function)+  +: fun   (genMaybe @Text)+  +: fun   (genList @Text)+  +: fun   genInt+  +: fun   genText+  +: fun   genTextToInt+  +: fun   genDynamic+  +: fun   genSomeTypeRep+  +: end++-- * generators+newtype TextToInt = TextToInt (Text -> Int)+instance Show TextToInt where show _ = "<function>"+instance Eq TextToInt where _ == _ = True++genTextToInt :: Gen TextToInt+genTextToInt = pure (TextToInt T.length)++data UntypedRegistry = UntypedRegistry {+    _uvalues          :: Values+  , _ufunctions       :: Functions+  , _uspecializations :: Specializations+  , _umodifiers       :: Modifiers+  } deriving (Show)++genValues :: Gen (Int, Values)+genValues = do+  value  <- genInt+  values  <- makeUnsafe @(Gen Values) gensRegistry+  pure (value, createValue value `addValue` values)++genSomeTypeRep :: Gen Value -> Gen SomeTypeRep+genSomeTypeRep = fmap valueDynTypeRep++genDynamic :: Gen Dynamic+genDynamic = Gen.element [toDyn (1 :: Int), toDyn (2 :: Int), toDyn ("1" :: Text)]++genList :: forall a . Gen a -> Gen [a]+genList = Gen.list (Range.linear 1 3)++genNonEmpty :: forall a . Gen a -> Gen (NonEmpty a)+genNonEmpty genA = do+  ls <- Gen.list (Range.linear 1 3) genA+  case ls of+    -- this case can not happen+    [] -> pure <$> genA+    as -> pure (fromList as)++genMaybe :: forall a . Gen a -> Gen (Maybe a)+genMaybe = Gen.maybe++genPair :: forall a b . Gen a -> Gen b -> Gen (a, b)+genPair gena genb = (,) <$> gena <*> genb++genInt :: Gen Int+genInt = Gen.int (Range.linear 0 5)++genText :: Gen Text+genText = Gen.text (Range.linear 2 10) Gen.alphaNum++genModifierFunction :: Gen Function -> Gen ModifierFunction+genModifierFunction genF = do+  f <- genF+  pure (const f)

@@ -10,8 +10,9 @@ import           Data.Registry.Internal.Registry import           Data.Registry.Internal.Stack import           Data.Registry.Internal.Types-import           Protolude                        as P hiding (show)+import           Protolude                                as P hiding (show) import           Test.Data.Registry.Internal.Gens+import           Test.Data.Registry.Internal.GensRegistry import           Test.Tasty.Extensions  test_find_no_value = prop "no value can be found if nothing is stored in the registry" $ do@@ -60,7 +61,7 @@   (value, values) <- forAll genValues    let valueType = dynTypeRep . toDyn $ value-  let modifiers = Modifiers [(valueType, createFunction (\(i:: Int) -> i + 1))]+  let modifiers = Modifiers [(valueType, createConstModifierFunction (\(i:: Int) -> i + 1))]   let createdValue = createValue value   let (Right stored) = execStackWithValues values (storeValue modifiers createdValue) @@ -72,8 +73,8 @@    let valueType = dynTypeRep . toDyn $ value   let modifiers = Modifiers [-         (valueType, createFunction (\(i:: Int) -> i * 2))-       , (valueType, createFunction (\(i:: Int) -> i + 1))+         (valueType, createConstModifierFunction (\(i:: Int) -> i * 2))+       , (valueType, createConstModifierFunction (\(i:: Int) -> i + 1))        ]   let createdValue = createValue value   let (Right stored) = execStackWithValues values (storeValue modifiers createdValue)

@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds             #-}+{-# LANGUAGE IncoherentInstances   #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards       #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}@@ -194,3 +195,41 @@ newStatsStore client sql supervisor = 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 $+     specializePathUnsafeValTo @IO @[IO ToOverride, IO InCommon] (SomeConfig "specialized config") $+     valTo @IO (SomeConfig "default config")+  +: funTo @IO newToKeepDefault+  +: funTo @IO newToOverride+  +: funTo @IO InCommon+  +: funTo @IO SomeData+  +: end