registry 0.1.2.2 → 0.1.2.3

raw patch · 30 files changed

+1377/−522 lines, 30 filesdep +containersdep +hashabledep +semigroupoidsdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers, hashable, semigroupoids, semigroups

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• registry.cabal +19/−4
• src/Data/Registry.hs +8/−7
• src/Data/Registry/Dot.hs +5/−43
• src/Data/Registry/Internal/Cache.hs +1/−1
• src/Data/Registry/Internal/Dot.hs +135/−0
• src/Data/Registry/Internal/Dynamic.hs +5/−2
• src/Data/Registry/Internal/Make.hs +5/−4
• src/Data/Registry/Internal/Operations.hs +0/−73
• src/Data/Registry/Internal/Registry.hs +55/−24
• src/Data/Registry/Internal/Stack.hs +26/−14
• src/Data/Registry/Internal/Statistics.hs +71/−0
• src/Data/Registry/Internal/Types.hs +186/−21
• src/Data/Registry/Make.hs +1/−1
• src/Data/Registry/RIO.hs +61/−24
• src/Data/Registry/Registry.hs +115/−8
• src/Data/Registry/Statistics.hs +58/−0
• test/Test/Data/Registry/DotSpec.hs +27/−43
• test/Test/Data/Registry/Internal/CacheSpec.hs +3/−4
• test/Test/Data/Registry/Internal/Gens.hs +14/−3
• test/Test/Data/Registry/Internal/MakeSpec.hs +2/−4
• test/Test/Data/Registry/Internal/RegistrySpec.hs +4/−4
• test/Test/Data/Registry/Internal/TypesSpec.hs +45/−0
• test/Test/Data/Registry/Make.hs +0/−235
• test/Test/Data/Registry/Make/MakeSpec.hs +46/−0
• test/Test/Data/Registry/Make/MemoizeSpec.hs +104/−0
• test/Test/Data/Registry/Make/SpecializationSpec.hs +200/−0
• test/Test/Data/Registry/Make/TweakingSpec.hs +32/−0
• test/Test/Data/Registry/RIOSpec.hs +1/−0
• test/Test/Data/Registry/SimpleExamples.hs +110/−0
• test/Test/Data/Registry/WarmupSpec.hs +38/−3

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 7566c8a11593eb9d930102b802543fdd53f6664c7b6d041c3fe6d67c48386775+-- hash: e570c9eb12f1d7452ae6ba23b2fd2fde606bc45719f4bc981ddea25dc2b18704  name:           registry-version:        0.1.2.2+version:        0.1.2.3 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.@@ -26,18 +26,20 @@       Data.Registry       Data.Registry.Dot       Data.Registry.Internal.Cache+      Data.Registry.Internal.Dot       Data.Registry.Internal.Dynamic       Data.Registry.Internal.Make-      Data.Registry.Internal.Operations       Data.Registry.Internal.Reflection       Data.Registry.Internal.Registry       Data.Registry.Internal.Stack+      Data.Registry.Internal.Statistics       Data.Registry.Internal.Types       Data.Registry.Lift       Data.Registry.Make       Data.Registry.Registry       Data.Registry.RIO       Data.Registry.Solver+      Data.Registry.Statistics       Data.Registry.Warmup   other-modules:       Paths_registry@@ -47,10 +49,14 @@   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+    , containers <0.7     , exceptions <0.11+    , hashable <1.3     , mtl <3     , protolude <0.3     , resourcet <1.3+    , semigroupoids <5.4+    , semigroups <0.19     , text <2     , transformers-base <0.5   default-language: Haskell2010@@ -67,10 +73,15 @@       Test.Data.Registry.Internal.MakeSpec       Test.Data.Registry.Internal.ReflectionSpec       Test.Data.Registry.Internal.RegistrySpec-      Test.Data.Registry.Make+      Test.Data.Registry.Internal.TypesSpec+      Test.Data.Registry.Make.MakeSpec+      Test.Data.Registry.Make.MemoizeSpec+      Test.Data.Registry.Make.SpecializationSpec+      Test.Data.Registry.Make.TweakingSpec       Test.Data.Registry.MonadRandomSpec       Test.Data.Registry.RegistrySpec       Test.Data.Registry.RIOSpec+      Test.Data.Registry.SimpleExamples       Test.Data.Registry.SmallExample       Test.Data.Registry.WarmupSpec       Test.Tasty.Extensions@@ -83,7 +94,9 @@       MonadRandom <0.6     , async <2.3     , base >=4.7 && <5+    , containers <0.7     , exceptions <0.11+    , hashable <1.3     , hedgehog <0.7     , hedgehog-corpus <0.2     , io-memoize <1.2@@ -92,6 +105,8 @@     , random <2.0     , registry     , resourcet <1.3+    , semigroupoids <5.4+    , semigroups <0.19     , tasty <1.3     , tasty-discover <4.3     , tasty-hedgehog <0.3

@@ -8,10 +8,11 @@   module M ) where -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+import           Data.Registry.Dot        as M -- Produce a graph out of a registry+import           Data.Registry.Statistics as M -- Provide statistics about the execution 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

@@ -7,24 +7,18 @@   out of a 'Registry'. -} module Data.Registry.Dot (-  module O+  module D , makeDot , makeDotEither , makeDotFast , makeDotUnsafe-, makeOperationsEither-, makeOperationsUnsafe ) where -import           Data.Registry.Internal.Make-import           Data.Registry.Internal.Operations as O-import           Data.Registry.Internal.Stack-import           Data.Registry.Internal.Types+import           Data.Registry.Internal.Dot as D+import           Data.Registry.Statistics import           Data.Registry.Registry import           Data.Registry.Solver-import           Prelude                           (error) import           Protolude-import           Type.Reflection  -- | Make a DOT graph for a specific value `a` built from the 'Registry' --   `a` is at the root of the graph and its children are values@@ -44,41 +38,9 @@ -- | Similar to `make` but does not check if `a` can be made out of the 'Regisry' --   It returns a Left value if that's not the case makeDotEither :: forall a ins out . (Typeable a) => Registry ins out -> Either Text Dot-makeDotEither r = toDot <$> makeOperationsEither @a r+makeDotEither r = toDot . operations <$> makeStatisticsEither @a r  -- | Similar to `make` but does not check if `a` can be made out of the 'Regisry' --   and throws an exception if that's not the case makeDotUnsafe :: forall a ins out . (Typeable a) => Registry ins out -> Dot-makeDotUnsafe = toDot . makeOperationsUnsafe @a---- | Return an `Operations` value listing all the function applications necessary to---   create a value of a given type-makeOperationsEither :: forall a ins out . (Typeable a) => Registry ins out -> Either Text Operations-makeOperationsEither registry =-  let values          = _values registry-      functions       = _functions registry-      specializations = _specializations registry-      modifiers       = _modifiers registry-      targetType      = someTypeRep (Proxy :: Proxy a)-  in-      -- 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 evalStack) values-          (makeUntyped targetType (Context [targetType]) functions specializations modifiers)--      of-        Left e ->-          Left $ "could not create a " <> show targetType <> " out of the registry because " <> e <> "\nThe registry is\n" <>-                 show registry--        other ->-          other---- | Return an `Operations` value listing all the function applications necessary to---   create a value of a given type (and throws an exception if the value cannot be created)-makeOperationsUnsafe  :: forall a ins out . (Typeable a) => Registry ins out -> Operations-makeOperationsUnsafe registry =-  case makeOperationsEither @a registry of-    Right a -> a-    Left  e -> Prelude.error (toS e)+makeDotUnsafe = toDot . operations . makeStatisticsUnsafe @a

@@ -1,6 +1,6 @@ {- | - Cache for individual IO values when we wish to make singletons+ 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

@@ -0,0 +1,135 @@+{- |+  Nested datatype to track the resolution algorithm++  From this data type we can draw a graph of the full+  instantation of a value+-}+module Data.Registry.Internal.Dot where++import           Data.Hashable+import           Data.List                         (elemIndex)+import           Data.Map.Strict                   hiding (adjust)+import           Data.Registry.Internal.Statistics+import           Data.Registry.Internal.Types+import           Data.Text                         as T+import           Protolude                         as P+import           Type.Reflection++-- | Make a list of graph edges from the list of function applications+makeEdges :: Operations -> [(Value, Value)]+makeEdges []                               = []+makeEdges (AppliedFunction out ins : rest) = ((out,) <$> ins) <> makeEdges rest++-- * DOT GRAPH++-- | A DOT graph+newtype Dot = Dot {+  unDot :: Text+} deriving (Eq, Show)++-- Use a State type to get the current index of a value+-- when there are values of the same type and different+-- hash values+type DotState = State ValuesByType+type ValuesByType = Map SomeTypeRep ValueHashes+type Hash = Int+type ValueId = Int+type ValueHashes = [Hash]+type Edge = (Value, Value)+type Edges = [Edge]+type ValueCounter = Maybe Int++-- | Make a DOT graph out of all the function applications+toDot :: Operations -> Dot+toDot op =+  let edges = makeEdges op+      allValues = join $ (\(v1, v2) -> [v1, v2]) <$> edges+      valueTypes = execState (traverse countValueTypes allValues) mempty+  in Dot $+       T.unlines $+       [ "strict digraph {"+       ,  "  node [shape=record]"+       ]+       <> (toDotEdge valueTypes <$> edges)+       <> ["}"]++-- | Update a map classifying values by type+countValueTypes :: Value -> DotState ()+countValueTypes value = do+  maps <- get+  let key = valueDynTypeRep value+  let valueHash = hashOf value++  case lookup key maps of+    -- there were no values for that type, create a list with the value hash+    Nothing -> put $ insert key [valueHash] maps++    -- there is a list of hashes for that type+    Just hashes ->+      case elemIndex valueHash hashes of+        -- that value hasn't been seen before+        Nothing -> do+          let newHashes = hashes <> [valueHash]+          put $ insert key newHashes maps++        -- the value has been seen before+        Just _ -> pure ()++-- | A DOT edge representing the dependency between 2 values+toDotEdge :: ValuesByType -> (Value, Value) -> Text+toDotEdge valuesByType (value1, value2) =+  let v1 = toDotVertex valuesByType value1+      v2 = toDotVertex valuesByType value2+  in  v1 <> " -> "  <> v2 <> ";"++-- | Represent a value as a vertex in a dot graph+--   we use some state to keep track of values of the+--   same type+--   The values are numbered starting from 1 when there are+--   several of them for the same type+toDotVertex :: ValuesByType -> Value -> Text+toDotVertex valuesByType value =+  let key = valueDynTypeRep value+      valueHash = hashOf value++      valueCounter =+        case lookup key valuesByType of+          Nothing -> Nothing -- this case should not happen given how the map is built+          Just hashes ->+            if P.length hashes == 1 then Nothing+            else (+1) <$> elemIndex valueHash hashes++  in adjust (nodeDescription (valDescription value) valueCounter)++-- | Return the hash of a value based on its dependencies+hashOf :: Value -> Int+hashOf value = hash+  (unDependencies . valDependencies $ value, valDescription value)++-- | Description of a Value in the DOT graph+nodeDescription :: ValueDescription -> ValueCounter -> Text+nodeDescription (ValueDescription t Nothing) n =+  t <> showValueCounter n+nodeDescription (ValueDescription t (Just v)) n =+  nodeDescription (ValueDescription t Nothing) n <> "\n" <> v++-- | Don't show the counter if there+showValueCounter :: ValueCounter -> Text+showValueCounter Nothing  = ""+showValueCounter (Just n) = "-" <> show n++-- | We need to process the node descriptions+--     - we add quotes arountd the text+--     - we remove quotes (") inside the text+--     - we escape newlines+adjust :: Text -> Text+adjust node = "\"" <> (escapeNewlines . removeQuotes) node <> "\""++-- | Remove quotes from a textual description to avoid breaking the DOT format+removeQuotes :: Text -> Text+removeQuotes = T.replace "\"" ""++-- | Replace \n with \\n so that newlines are kept in+--   node descriptions+escapeNewlines :: Text -> Text+escapeNewlines = T.replace "\n" "\\n"

@@ -18,7 +18,7 @@   -> Either Text Value  -- ^ result applyFunction function [] =   if P.null (collectInputTypes function) then-    pure $ CreatedValue (funDyn function) (ValueDescription (_outputType . funDescription $ function) Nothing)+    pure $ makeCreatedValue (funDyn function) (ValueDescription (_outputType . funDescription $ function) Nothing) mempty   else     Left $  "the function "     <> show (dynTypeRep (funDyn function))@@ -26,7 +26,10 @@  applyFunction function values =   do created <- applyFunctionDyn (funDyn function) (valueDyn <$> values)-     pure $ CreatedValue created (ValueDescription (_outputType . funDescription $ function) Nothing)+     let description  = ValueDescription (_outputType . funDescription $ function) Nothing+     let dependencies = foldMap dependenciesOn values++     pure $ makeCreatedValue created description dependencies  -- | Apply a Dynamic function to a list of Dynamic values applyFunctionDyn ::

@@ -41,9 +41,10 @@   -> Stack (Maybe Value) makeUntyped targetType context functions specializations modifiers = do   values <- getValues-   -- is there already a value with the desired type?-  case findValue targetType context specializations values of+  let foundValue = findValue targetType context specializations values++  case foundValue of     Nothing ->       -- if not, is there a way to build such value?       case findConstructor targetType functions of@@ -67,8 +68,8 @@                 <> 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+              value <- lift $ applyFunction function inputs+              modified <- storeValue modifiers value                functionApplied modified inputs               pure (Just modified)

@@ -1,73 +0,0 @@-{- |-  Nested datatype to track the resolution algorithm--  From this data type we can draw a graph of the full-  instantation of a value--}-module Data.Registry.Internal.Operations where--import           Data.Registry.Internal.Types-import           Data.Text as T-import           Protolude---- | A list of function applications created---   when creating a value out of the Registry-type Operations = [AppliedFunction]---- | A function application with an output value and a list of input values-data AppliedFunction = AppliedFunction {-    _outputValue :: Value-  , _inputValues ::[Value]-  } deriving (Show)---- | Make a list of graph edges from the list of function applications-makeEdges :: Operations -> [(Value, Value)]-makeEdges [] = []-makeEdges (AppliedFunction out ins : rest) =-  ((out,) <$> ins) <>-  makeEdges rest---- * DOT GRAPH---- | A DOT graph-newtype Dot = Dot {-  unDot :: Text-  } deriving (Eq, Show)---- | Make a DOT graph out of all the function applications-toDot :: Operations -> Dot-toDot op = Dot $ T.unlines $-  [ "strict digraph {"-  ,  "  node [shape=record]"-  ]-  <> (toDotEdge <$> makeEdges op)-  <> ["}"]---- | A DOT edge representing the dependency between 2 values-toDotEdge :: (Value, Value) -> Text-toDotEdge (v1, v2) =-     adjust (nodeDescription . valDescription $ v1)-  <> " -> "-  <> adjust (nodeDescription . valDescription $ v2)-  <> ";"---- | Description of a Value in the DOT graph-nodeDescription :: ValueDescription -> Text-nodeDescription (ValueDescription t Nothing) = t-nodeDescription (ValueDescription t (Just v)) = t <> "\n" <> v---- | We need to process the node descriptions---     - we add quotes arountd the text---     - we remove quotes (") inside the text---     - we escape newlines-adjust :: Text -> Text-adjust t = "\"" <> (escapeNewlines . removeQuotes) t <> "\""---- | Remove quotes from a textual description to avoid breaking the DOT format-removeQuotes :: Text -> Text-removeQuotes = T.replace "\"" ""---- | Replace \n with \\n so that newlines are kept in---   node descriptions-escapeNewlines :: Text -> Text-escapeNewlines = T.replace "\n" "\\n"

@@ -1,7 +1,7 @@-{-# LANGUAGE AllowAmbiguousTypes        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE MonoLocalBinds             #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE AllowAmbiguousTypes  #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE MonoLocalBinds       #-}+{-# LANGUAGE UndecidableInstances #-}  {- |   Internal structure of a 'Registry' and@@ -10,9 +10,9 @@ module Data.Registry.Internal.Registry where  import           Data.Registry.Internal.Dynamic-import           Data.Registry.Internal.Types import           Data.Registry.Internal.Stack-import           Protolude                       as P+import           Data.Registry.Internal.Types+import           Protolude                      as P import           Type.Reflection  -- | Find a value having a target type from:@@ -20,32 +20,63 @@ --        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)+--     - a list of already created values (Values)+--+--  3 subtleties:+--    1. if there are specialized values we need to find the most specialized for+--      the current context, that is the one having its "targetType" the "lowest" in the+--      values graph+--+--    2. if an already created value has the right type but if it is a specialization+--       and the type we are looking for is not in the specialization context+--       then we cannot use that value, we need to recreate a brand new one+--+--    3. if an already created value has the right type and is not specialized+--       but if there is an incompatible specialization for one of its dependencies+--       then it cannot be used+-- findValue ::      SomeTypeRep   -> Context   -> Specializations   -> Values   -> Maybe Value--- no specializations or values to choose from-findValue _ _ (Specializations []) (Values []) = Nothing+findValue target context specializations values =+  let -- 1. first try to find the target value in the list of specializations+      -- those all are all the specializations which make sense in this context+      applicableSpecializations = (specializations `applicableTo` context)+      bestSpecializedValue = findBestSpecializedValue target context applicableSpecializations --- recurse on the specializations first-findValue target (Context context) (Specializations ((t, v) : rest)) values =-  -- if there is an override which value matches the current target-  -- and if that override is in the current context then return the value-  if target == valueDynTypeRep v && t `elem` context then-    Just v-  else-    findValue target (Context context) (Specializations rest) values+      compatibleValue = findCompatibleCreatedValue target specializations values --- otherwise recurse on the list of constructors until a value--- with the target type is found-findValue target context specializations (Values (v : rest)) =-  if valueDynTypeRep v == target then-    Just v-  else-    findValue target context specializations (Values rest)+  in bestSpecializedValue <|> compatibleValue++-- | Among all the applicable specializations take the most specific one+--   if there exists any+findBestSpecializedValue :: SomeTypeRep -> Context -> Specializations -> Maybe Value+findBestSpecializedValue target context (Specializations sp) =+  let -- the candidates must have the required type+      specializationCandidates = filter (\s -> target == specializationTargetType s) sp+      -- the best specialization is the one having its last context type the deepest in the current context+      bestSpecializations = sortOn (specializedContext context) specializationCandidates+      bestSpecializedValue = head bestSpecializations++  in  createValueFromSpecialization context <$> bestSpecializedValue++-- | Among all the created values, take a compatible one+--+--    - if that value is a specialized value or has specialized+--      dependencies it must be compatible with the current context+findCompatibleCreatedValue :: SomeTypeRep -> Specializations -> Values -> Maybe Value+findCompatibleCreatedValue target specializations (Values vs) =+  let isApplicableValue value = valueDynTypeRep value == target+      isNotSpecializedForAnotherContext value =+        not (hasSpecializedDependencies specializations value) &&+        not (isInSpecializationContext target value)++      applicableValues = filter ((&&) <$> isApplicableValue <*> isNotSpecializedForAnotherContext) vs++  in  head applicableValues  -- | Find a constructor function returning a target type --   from a list of constructors

@@ -8,41 +8,53 @@ -} module Data.Registry.Internal.Stack where -import           Data.Registry.Internal.Operations+import           Data.Registry.Internal.Statistics import           Data.Registry.Internal.Types import           Protolude  -- | Monadic stack for the resolution algorithm-type Stack a = StateT (Values, Operations) (Either Text) a+type Stack a = StateT Statistics (Either Text) a  -- | Return a value from the Stack if possible-runStack :: Stack a -> Values -> Either Text a-runStack sa vs = evalStateT sa (vs, [])+runStack :: Stack a -> Either Text a+runStack = runStackWithValues mempty +-- | Return a value from the Stack if possible+runStackWithValues :: Values -> Stack a -> Either Text a+runStackWithValues vs sa = evalStateT sa (initStatistics vs)++execStack :: Stack a -> Either Text Values+execStack = execStackWithValues mempty+ -- | Return the state of the stack after executing the action --   This returns the list of built values-execStack :: Stack a -> Values -> Either Text Values-execStack sa vs = fst <$> execStateT sa (vs, [])+execStackWithValues :: Values -> Stack a -> Either Text Values+execStackWithValues vs sa = values <$> execStateT sa (initStatistics vs)  -- | Return the list of applied functions after resolution-evalStack :: Stack a -> Values -> Either Text Operations-evalStack sa vs = snd <$> execStateT sa (vs, [])+evalStack :: Stack a -> Either Text Statistics+evalStack = evalStackWithValues mempty +evalStackWithValues :: Values -> Stack a -> Either Text Statistics+evalStackWithValues vs sa = execStateT sa (initStatistics vs)+ -- | Get the current list of values getValues :: Stack Values-getValues = fst <$> get+getValues = values <$> get  -- | Get the current list of operations-getOperation :: Stack Operations-getOperation = snd <$> get+getOperations :: Stack Operations+getOperations = operations <$> get  -- | Modify the current list of values modifyValues :: (Values -> Values) -> Stack ()-modifyValues f = modify (\(vs, ops) -> (f vs, ops))+modifyValues f = modifyStatistics (\s -> s { values = f (values s) }) --- | Get the current list of values modifyOperations :: (Operations -> Operations) -> Stack ()-modifyOperations f = modify (\(vs, ops) -> (vs, f ops))+modifyOperations f = modifyStatistics (\s -> s { operations = f (operations s) })++modifyStatistics :: (Statistics -> Statistics) -> Stack ()+modifyStatistics = modify  -- | Store a function application in the list of operations functionApplied :: Value -> [Value] -> Stack ()

@@ -0,0 +1,71 @@+{-+  This module provides a set of statistics over the execution+  of the registry. This allows to get better insights over the execution+  or test that the registry is well configured+-}+module Data.Registry.Internal.Statistics where++import           Data.Registry.Internal.Types+import           Protolude++-- * DATA TYPES++-- | This datatype records:+--    - the created values+--    - the applied functions+--    - the specializations used to create values+data Statistics = Statistics {+  operations :: Operations+, values     :: Values+} deriving (Show)++instance Semigroup Statistics where+  Statistics ops1 vs1 <> Statistics ops2 vs2 =+    Statistics (ops1 <> ops2) (vs1 <> vs2)++instance Monoid Statistics where+  mempty = Statistics mempty mempty+  mappend = (<>)++-- | A list of function applications created+--   when creating a value out of the Registry+type Operations = [AppliedFunction]++-- | List of distinct paths from the root of the value graph to a leaf+type Paths = [[Value]]++-- | A function application with an output value and a list of input values+data AppliedFunction = AppliedFunction {+  _outputValue :: Value+, _inputValues ::[Value]+} deriving (Show)++initStatistics :: Values -> Statistics+initStatistics vs = mempty { values = vs }++-- | Return the specializations used during the creation of values+usedSpecializations :: Statistics -> [Specialization]+usedSpecializations stats =+  case values stats of+    Values [] -> []+    Values (v : vs) ->+      case usedSpecialization v of+        Just s  -> s : usedSpecializations stats { values = Values vs }+        Nothing -> usedSpecializations stats { values = Values vs }++-- | Return the list of distinct paths from the root of a value graph to leaves+--   of that graph.+--   This can be used to check if a given value was indeed used according to a given+--   specialization+allValuesPaths :: Statistics -> Paths+allValuesPaths stats = do+  v <- unValues $ values stats+  valuePaths v++-- | Return all the paths from a given value to all its dependencies+valuePaths :: Value -> Paths+valuePaths v@(CreatedValue _ _ _ _ (Dependencies ds)) = do+  d <- ds+  (v :) <$> valuePaths d++valuePaths _ = []

@@ -1,39 +1,52 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}- {- |   List of types used inside the Registry -} module Data.Registry.Internal.Types where  import           Data.Dynamic+import           Data.Hashable+import           Data.List                         (elemIndex, intersect)+import           Data.List.NonEmpty+import           Data.List.NonEmpty                as NonEmpty (head, last) import           Data.Registry.Internal.Reflection-import           Data.Text                         as T+import           Data.Text                         as T hiding (last) import           Prelude                           (show) import           Protolude                         as P hiding (show) import qualified Protolude                         as P import           Type.Reflection + -- | 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+--   If a `Context` is present for a a created value this means that this value+--   has been written as the result of a specialization. The first type of the+--   list of types in the context is the types under which the specialization must+--   apply and the other types are "parents" of the current value in the value+--   graph data Value =-    CreatedValue  Dynamic ValueDescription+    CreatedValue  Dynamic ValueDescription (Maybe Context) (Maybe Specialization) Dependencies   | ProvidedValue Dynamic ValueDescription   deriving (Show) --- | Return the dynamic part of a value-getValueDynamic :: Value -> Dynamic-getValueDynamic (CreatedValue d _)  = d-getValueDynamic (ProvidedValue d _) = d+instance Hashable Value where+  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 data ValueDescription = ValueDescription {     _valueType  :: Text   , _valueValue :: Maybe Text-  } deriving (Eq, Show)+ } deriving (Eq, Show) +instance Hashable ValueDescription where+  hash (ValueDescription d v) = hash (d, v)+  hashWithSalt n (ValueDescription d v) = hashWithSalt n (d, v)+ -- | Describe a value with its type and actual content describeValue :: (Typeable a, Show a) => a -> ValueDescription describeValue a = ValueDescription (showFullValueType a) (Just . toS $ show a)@@ -46,10 +59,18 @@ showValue :: Value -> Text showValue = valDescriptionToText . valDescription --- | Create a Value from a Haskell value, with its 'Show' description-createValue :: (Show a, Typeable a) => a -> Value-createValue a = ProvidedValue (toDyn a) (describeValue a)+-- | Create a Value from a Haskell value, using its Show instance for its description+createValue :: (Typeable a, Show a) => a -> Value+createValue a = makeProvidedValue (toDyn a) (describeValue a) +-- | Make a ProvidedValue+makeProvidedValue :: Dynamic -> ValueDescription -> Value+makeProvidedValue = ProvidedValue++-- | make a CreatedValue in no particular context+makeCreatedValue :: Dynamic -> ValueDescription -> Dependencies -> Value+makeCreatedValue d desc = CreatedValue d desc Nothing Nothing+ -- | Create a Value from a Haskell value, with only its 'Typeable' description createTypeableValue :: Typeable a => a -> Value createTypeableValue a = ProvidedValue (toDyn a) (describeTypeableValue a)@@ -60,25 +81,56 @@  -- | Type representation of a 'Value' valueDynTypeRep :: Value -> SomeTypeRep-valueDynTypeRep (CreatedValue  d _) = dynTypeRep d-valueDynTypeRep (ProvidedValue d _) = dynTypeRep d+valueDynTypeRep = dynTypeRep . valueDyn  -- | Dynamic representation of a 'Value' valueDyn :: Value -> Dynamic-valueDyn (CreatedValue  d _) = d-valueDyn (ProvidedValue d _) = d+valueDyn (CreatedValue  d _ _ _ _) = d+valueDyn (ProvidedValue d _)     = d  -- | The description for a 'Value' valDescription :: Value -> ValueDescription-valDescription (CreatedValue  _ d) = d-valDescription (ProvidedValue _ d) = d+valDescription (CreatedValue  _ d _ _ _ ) = d+valDescription (ProvidedValue _ d)      = d +-- | The dependencies for a 'Value'+valDependencies :: Value -> Dependencies+valDependencies (CreatedValue  _ _ _ _ ds) = ds+valDependencies (ProvidedValue _ _)      = mempty+ -- | A ValueDescription as 'Text'. If the actual content of the 'Value' --   is provided display the type first then the content valDescriptionToText :: ValueDescription -> Text valDescriptionToText (ValueDescription t Nothing)  = t valDescriptionToText (ValueDescription t (Just v)) = t <> ": " <> v +-- | Return the creation context for a given value when it was created+--   as the result of a "specialization"+specializationContext :: Value -> Maybe Context+specializationContext (CreatedValue _ _ context _ _) = context+specializationContext _                            = Nothing++-- | Return the specialization used to create a specific values+usedSpecialization :: Value -> Maybe Specialization+usedSpecialization (CreatedValue _ _ _ specialization _) = specialization+usedSpecialization _                                     = Nothing++-- | Return True if a type is part of the specialization context of a Value+isInSpecializationContext :: SomeTypeRep -> Value -> Bool+isInSpecializationContext target value =+  case specializationContext value of+    Just (Context cs) -> target `elem` cs+    Nothing           -> False++-- | Return True if a value has transitives dependencies which are+--   specialized values+hasSpecializedDependencies :: Specializations -> Value -> Bool+hasSpecializedDependencies (Specializations ss) v =+  let DependenciesTypes ds = dependenciesTypes $ valDependencies v+      targetTypes = specializationTargetType <$> ss++  in  not . P.null $ targetTypes `intersect` ds+ -- | A Function is the 'Dynamic' representation of a Haskell function + its description data Function = Function Dynamic FunctionDescription deriving (Show) @@ -147,7 +199,7 @@  -- | List of values available which can be used as parameters to --   constructors for building other values-newtype Values = Values [Value] deriving (Show, Semigroup, Monoid)+newtype Values = Values { unValues :: [Value] } deriving (Show, Semigroup, Monoid)  -- | Display a list of values describeValues :: Values -> Text@@ -162,12 +214,125 @@ addValue v (Values vs) = Values (v : vs)  -- | 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)+--   of the resolution algorithm.+--   IMPORTANT: this is a *stack*, the deepest elements in the value+--   graph are first in the list+newtype Context = Context {+  _contextStack :: [SomeTypeRep]+} deriving (Eq, Hashable, Show, Semigroup, Monoid) +-- | The values that a value depends on+newtype Dependencies = Dependencies {+  unDependencies :: [Value]+} deriving (Show, Hashable, Semigroup, Monoid)++-- | The values types that a value depends on+newtype DependenciesTypes = DependenciesTypes {+  unDependenciesTypes :: [SomeTypeRep]+} deriving (Eq, Show, Semigroup, Monoid)++dependenciesTypes :: Dependencies -> DependenciesTypes+dependenciesTypes (Dependencies ds) = DependenciesTypes (valueDynTypeRep <$> ds)++-- | The dependencies of a value + the value itself+dependenciesOn :: Value -> Dependencies+dependenciesOn value = Dependencies $+  value : (unDependencies . valDependencies $ value)+ -- | Specification of values which become available for --   construction when a corresponding type comes in context-newtype Specializations = Specializations [(SomeTypeRep, Value)] deriving (Show, Semigroup, Monoid)+newtype Specializations = Specializations {+  unSpecializations :: [Specialization]+} deriving (Show, Semigroup, Monoid)++-- | 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+--   on that path.+--   For example:+--      specializationPath = [App, PaymentEngine, TransactionRepository]+--      specializationValue = DatabaseConfig "localhost" 5432+--   This means that need to use this `DatabaseConfig` whenever+--   trying to find inputs needed to create a TransactionRepository+--   if that repository is necessary to create a PaymentEngine, itself+--   involved in the creation of the App+data Specialization = Specialization {+  _specializationPath  :: NonEmpty SomeTypeRep+, _specializationValue :: Value+} deriving (Show)++-- | First type of a specialization+specializationStart :: Specialization -> SomeTypeRep+specializationStart = NonEmpty.head . _specializationPath++-- | Last type of a specialization+specializationEnd :: Specialization -> SomeTypeRep+specializationEnd = NonEmpty.last . _specializationPath++-- | Return the type of the replaced value in a specialization+specializationTargetType :: Specialization -> SomeTypeRep+specializationTargetType = valueDynTypeRep . _specializationValue++-- | A specialization is applicable to a context if all its types+--   are part of that context, in the right order+isContextApplicable :: Context -> Specialization -> Bool+isContextApplicable (Context contextPath) (Specialization specializationPath _)  =+  P.all (`elem` contextPath) specializationPath++-- | Return the specifications valid in a given context+applicableTo :: Specializations -> Context -> Specializations+applicableTo (Specializations ss) context =+  Specializations (P.filter (isContextApplicable context) ss)++-- | The depth of a specialization in a context is the+--   the index of the 'deepest' type of that specialization+--   in the stack of types of that context+--   is the one having its "deepest" type (in the value graph)+--     the "deepest" in the current context+--   If there is a tie we take the "highest" highest type of each+specializedContext :: Context -> Specialization -> SpecializedContext+specializedContext (Context cs) specialization =+  SpecializedContext+    (specializationStart specialization `elemIndex` cs)+    (specializationEnd   specialization `elemIndex` cs)++-- | For a given context this represents the position of a specialization path+--   in that context. startRange is the index of the start type of the specialization+--   endRange is the index of the last type.+data SpecializedContext = SpecializedContext {+  _startRange :: Maybe Int+, _endRange   :: Maybe Int+} deriving (Eq, Show)++-- | A specialization range is preferrable to another one if its types+--   are more specific (or "deepest" in the value graph) than the other+--   If a path is limited to just one type then a path ending with the same+--   type but specifying other types will take precedence+--   See TypesSpec for some concrete examples.+instance Ord SpecializedContext where+  SpecializedContext s1 e1 <= SpecializedContext s2 e2+    | e1 /= s1 && e2 /= s2 = e1 <= e2 || (e1 == e2 && s1 <= s2)+    | e1 == s1 && e2 /= s2 = e1 < e2+    | otherwise            = e1 <= e2++-- | Restrict a given context to the types of a specialization+-- specializedContext :: Context -> Specialization -> Context+-- specializedContext (Context cs) specialization = Context $+--   P.dropWhile    (/= specializationEnd specialization) .+--   dropWhileEnd (/= specializationStart specialization) $ cs++-- | In a given context, create a value as specified by a specialization+--   the full context is necessary since the specificationPath is+--   only a subpath of a given creation context+createValueFromSpecialization :: Context -> Specialization -> Value+createValueFromSpecialization context specialization@(Specialization _ (ProvidedValue d desc)) =+  -- the creation context for that value+  CreatedValue d desc (Just context) (Just specialization) mempty++-- this is not supposed to happen since specialization are always+-- using ProvidedValues+createValueFromSpecialization _ v = _specializationValue v  -- | Display a list of specializations for the Registry, just showing the --   context (a type) in which a value must be selected

@@ -69,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+        runStackWithValues values           (makeUntyped targetType (Context [targetType]) functions specializations modifiers)        of

@@ -1,7 +1,8 @@-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE IncoherentInstances   #-}-{-# LANGUAGE MonoLocalBinds        #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE IncoherentInstances  #-}+{-# LANGUAGE MonoLocalBinds       #-}+{-# LANGUAGE UndecidableInstances #-} {- |    RIO is equivalent to @ResourceT (WriterT Warmup IO)@@@ -18,11 +19,13 @@ import           Control.Monad.Trans.Resource import qualified Control.Monad.Trans.Resource as Resource (allocate) +import           Control.Applicative+import           Data.Functor.Alt import           Data.Registry.Make import           Data.Registry.Registry import           Data.Registry.Solver import           Data.Registry.Warmup-import           Protolude+import           Protolude                    hiding (Alt, try)  -- | Data type encapsulating resource finalizers newtype Stop = Stop InternalState@@ -39,7 +42,7 @@  instance Applicative RIO where   pure a =-    RIO(const (pure (a, mempty)))+    RIO (const (pure (a, mempty)))    RIO fab <*> RIO fa =     RIO $ \s ->@@ -68,12 +71,25 @@ instance MonadResource RIO where   liftResourceT action = RIO $ \(Stop s) -> liftIO ((, mempty) <$> runInternalState action s) +-- We cannot piggy-back on the IO Alternative instance+-- because it only catches IOErrors+instance Alternative RIO where+  empty = RIO (const empty)+  (RIO runA) <|> (RIO runB) = RIO $ \s -> do+    res <- try (runA s)+    case res of+      Left (_::SomeException) -> runB s+      Right r                 -> pure r++instance Alt RIO where+  (<!>) = (<|>)+ -- * For production  -- | Use a RIO value and make sure that resources are closed --   Only run the action if the warmup is successful-withRIO :: RIO a -> (a -> IO ()) -> IO Result-withRIO rio f = runResourceT $ withInternalState $ \is ->+withRIO :: (MonadIO m) => RIO a -> (a -> IO ()) -> m Result+withRIO rio f = liftIO $ runResourceT $ withInternalState $ \is ->   do  (a, warmup) <- runRIO rio (Stop is)       result      <- liftIO $ runWarmup warmup       if isSuccess result then f a else pure ()@@ -84,55 +100,76 @@ -- --   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) =>+--+--   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   -> (Result -> a -> IO b)-  -> IO b-withRegistry registry f = runResourceT $ do+  -> m b+withRegistry registry f = liftIO $ runResourceT $ do   (a, warmup) <- runRegistryT @a registry   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, Contains (RIO a) out, Solvable ins out, MonadIO m, MemoizedActions out)+  => Registry ins out+  -> ResourceT m (a, Warmup)+runRegistryT registry = withInternalState $ \is -> do+  r <- liftIO $ memoizeAll @RIO registry+  liftIO $ runRIO (make @(RIO a) r) (Stop is)  -- * For testing  -- | Use a RIO value and make sure that resources are closed --   Don't run the warmup-withNoWarmupRIO :: RIO a -> (a -> IO b) -> IO b-withNoWarmupRIO rio f =+withNoWarmupRIO :: (MonadIO m) => RIO a -> (a -> IO b) -> m b+withNoWarmupRIO rio f = liftIO $   runResourceT $ withInternalState $ \is ->   f . fst =<< runRIO rio (Stop is) +-- | Use a RIO value and make sure that resources are closed+--   Run the warmup but ignore the result+withRIOIgnoreWarmupResult :: (MonadIO m) => RIO a -> (a -> IO b) -> m b+withRIOIgnoreWarmupResult = withRIOAndWarmupResult (const $ pure ())++-- | Use a RIO value and make sure that resources are closed+--   Run a unit function with the warmup result (print or throw exception)+withRIOAndWarmupResult :: (MonadIO m) => (Result -> IO ()) -> RIO a -> (a -> IO b) -> m b+withRIOAndWarmupResult withResult rio f = liftIO $+  runResourceT $ withInternalState $ \is -> do+    (a, warmup) <- runRIO rio (Stop is)+    warmupResult <- liftIO $ runWarmup warmup+    withResult warmupResult+    liftIO (f a)+ -- | 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 registry = do+executeRegistry :: forall a ins out m . (Typeable a, Contains (RIO a) out, Solvable ins out, MonadIO m) => Registry ins out -> m (a, Warmup, Stop)+executeRegistry registry = liftIO $ do   is <- liftIO createInternalState   (a, w) <- runRIO (make @(RIO 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, Contains (RIO a) out, MonadIO m) => Registry ins out -> m a unsafeRun = unsafeRunDynamic  -- | Instantiate the component but don't execute the warmup (it may take time) and lose a way to cleanu up resources --   Don't even check that a component can be built out of the registry-unsafeRunDynamic :: forall a ins out . (Typeable a) => Registry ins out -> IO a-unsafeRunDynamic registry = fst <$> unsafeRunDynamicWithStop registry+unsafeRunDynamic :: forall a ins out m . (Typeable a, MonadIO m) => Registry ins out -> m a+unsafeRunDynamic registry = liftIO $ fst <$> unsafeRunDynamicWithStop 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, Contains (RIO a) out, MonadIO m) => Registry ins out -> m (a, Stop) unsafeRunWithStop = unsafeRunDynamicWithStop -unsafeRunDynamicWithStop :: forall a ins out . (Typeable a) => Registry ins out -> IO (a, Stop)-unsafeRunDynamicWithStop registry = do+unsafeRunDynamicWithStop :: forall a ins out m . (Typeable a, MonadIO m) => Registry ins out -> m (a, Stop)+unsafeRunDynamicWithStop registry = liftIO $ do   is <- createInternalState   (a, _) <- runRIO (makeUnsafe @(RIO a) registry) (Stop is)   pure (a, Stop is)

@@ -141,6 +141,12 @@   -> Registry ins out specialize = specializeUnsafe @a @b @ins @out +specializePath :: forall path b ins out . (PathToTypeReps path, IsSubset path out, Typeable b)+  => b+  -> Registry ins out+  -> Registry ins out+specializePath = specializePathUnsafe @path @b @ins @out+ -- | This is similar to specialize but additionally uses the 'Show' instance of @b@ --   to display more information when printing the registry out specializeVal :: forall a b ins out . (Typeable a, Contains a out, Typeable b, Show b)@@ -149,12 +155,24 @@   -> Registry ins out specializeVal = specializeUnsafeVal @a @b @ins @out +specializePathVal :: forall path b ins out . (PathToTypeReps path, IsSubset path out, Typeable b, Show b)+  => b+  -> Registry ins out+  -> Registry ins out+specializePathVal = specializePathUnsafeVal @path @b @ins @out+ specializeValTo :: forall m a b ins out . (Applicative m, Typeable a, Contains a out, Typeable (m b), Typeable b, Show b)   => b   -> Registry ins out   -> Registry ins out specializeValTo = specializeUnsafeValTo @m @a @b @ins @out +specializePathValTo :: forall m path b ins out . (Applicative m, PathToTypeReps path, IsSubset path out, Typeable (m b), Typeable b, Show b)+  => b+  -> Registry ins out+  -> Registry ins out+specializePathValTo = specializePathUnsafeValTo @m @path @b @ins @out+ -- | For a given type `a` being currently built --   when a value of type `b` is required pass a specific --   value@@ -165,9 +183,19 @@ specializeUnsafe b (Registry values functions (Specializations c) modifiers) = Registry   values   functions-  (Specializations ((someTypeRep (Proxy :: Proxy a), createTypeableValue b) : c))+  (Specializations (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (createTypeableValue b) : c))   modifiers +specializePathUnsafe :: forall path b ins out . (PathToTypeReps path, Typeable b)+  => b+  -> Registry ins out+  -> Registry ins out+specializePathUnsafe b (Registry values functions (Specializations c) modifiers) = Registry+  values+  functions+  (Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (createTypeableValue b) : c))+  modifiers+ specializeUnsafeVal :: forall a b ins out . (Typeable a, Contains a out, Typeable b, Show b)   => b   -> Registry ins out@@ -175,9 +203,19 @@ specializeUnsafeVal b (Registry values functions (Specializations c) modifiers) = Registry   values   functions-  (Specializations ((someTypeRep (Proxy :: Proxy a), createValue b) : c))+  (Specializations (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (createValue b) : c))   modifiers +specializePathUnsafeVal :: forall path b ins out . (PathToTypeReps path, Typeable b, Show b)+  => b+  -> Registry ins out+  -> Registry ins out+specializePathUnsafeVal b (Registry values functions (Specializations c) modifiers) = Registry+  values+  functions+  (Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (createValue b) : c))+  modifiers+ specializeUnsafeValTo :: forall m a b ins out . (Applicative m, Typeable a, Typeable (m b), Typeable b, Show b)   => b   -> Registry ins out@@ -185,9 +223,29 @@ specializeUnsafeValTo b (Registry values functions (Specializations c) modifiers) = Registry   values   functions-  (Specializations ((someTypeRep (Proxy :: Proxy a), liftProvidedValue @m b) : c))+  (Specializations (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (liftProvidedValue @m b) : c))   modifiers +specializePathUnsafeValTo :: forall m path b ins out . (Applicative m, PathToTypeReps path, Typeable (m b), Typeable b, Show b)+  => b+  -> Registry ins out+  -> Registry ins out+specializePathUnsafeValTo b (Registry values functions (Specializations c) modifiers) = Registry+  values+  functions+  (Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (liftProvidedValue @m b) : c))+  modifiers++-- | Typeclass for extracting type representations out of a list of types+class PathToTypeReps (path :: [*]) where+  someTypeReps :: Proxy path -> NonEmpty SomeTypeRep++instance {-# OVERLAPPING #-} (Typeable a) => PathToTypeReps '[a] where+  someTypeReps = const $ pure (someTypeRep (Proxy :: Proxy a))++instance (Typeable a, PathToTypeReps rest) => PathToTypeReps (a : rest) where+  someTypeReps = const $ someTypeRep (Proxy :: Proxy a) :| toList (someTypeReps (Proxy :: Proxy rest))+ -- | 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)@@ -205,17 +263,66 @@ tweakUnsafe f (Registry values functions specializations (Modifiers mf)) = Registry values functions specializations   (Modifiers ((someTypeRep (Proxy :: Proxy a), createFunction f) : mf)) --- | Return singleton values for a monadic type+-- * Memoization++-- | Instantiating components can trigger side-effects+--   The way the resolution algorithm works a component of type `m a` will be+--   re-executed *everytime* it is needed as a given dependency+--   This section adds support for memoizing those actions (component creation + optional warmup)++-- | 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!-singleton :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a), Contains (m a) out)+memoize :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a), Contains (m a) out)   => Registry ins out   -> IO (Registry ins out)-singleton = singletonUnsafe @m @a @ins @out+memoize = memoizeUnsafe @m @a @ins @out -singletonUnsafe :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a))+-- | Memoize an action for a given type but don't check if the value is part of the registry outputs+memoizeUnsafe :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a))   => Registry ins out   -> IO (Registry ins out)-singletonUnsafe r = do+memoizeUnsafe r = do   cache <- newCache @a   pure $ tweakUnsafe @(m a) (fetch cache) r++-- | 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)++newtype MemoizeRegistry (todo :: [*]) (ins :: [*]) (out :: [*]) = MemoizeRegistry { _unMemoizeRegistry :: Registry ins out }++startMemoizeRegistry :: Registry ins out -> MemoizeRegistry out ins out+startMemoizeRegistry = MemoizeRegistry++makeMemoizeRegistry :: forall todo ins out . Registry ins out -> MemoizeRegistry todo ins out+makeMemoizeRegistry = MemoizeRegistry @todo++class MemoizedActions ls where+  memoizeActions :: MemoizeRegistry ls ins out -> IO (MemoizeRegistry '[] ins out)++instance MemoizedActions '[] where+  memoizeActions = pure++instance {-# OVERLAPPING #-} (MonadIO m, Typeable a, Typeable (m a), MemoizedActions rest) => MemoizedActions (m a : rest) where+  memoizeActions (MemoizeRegistry r) = do+    r' <- memoizeUnsafe @m @a r+    memoizeActions (makeMemoizeRegistry @rest r')++instance (MemoizedActions rest) => MemoizedActions (a : rest) where+  memoizeActions (MemoizeRegistry r) =+    memoizeActions (makeMemoizeRegistry @rest r)++-- * DEPRECATIONS++{-# DEPRECATED singleton "use memoize instead" #-}+singleton :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a), Contains (m a) out) => Registry ins out -> IO (Registry ins out)+singleton = memoize @m @a @ins @out++{-# DEPRECATED singletonUnsafe "use memoizeUnsafe instead" #-}+singletonUnsafe :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a)) => Registry ins out -> IO (Registry ins out)+singletonUnsafe = memoizeUnsafe @m @a @ins @out

@@ -0,0 +1,58 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MonoLocalBinds      #-}++module Data.Registry.Statistics (+  module S+, makeStatistics+, makeStatisticsFast+, makeStatisticsEither+, makeStatisticsUnsafe+) where++import           Data.Registry.Internal.Make+import           Data.Registry.Internal.Statistics as S+import           Data.Registry.Internal.Stack+import           Data.Registry.Internal.Types+import           Data.Registry.Solver+import           Data.Registry.Registry+import           Prelude                           (error)+import           Protolude+import           Type.Reflection++makeStatistics :: forall a ins out . (Typeable a, Contains a out, Solvable ins out) => Registry ins out -> Statistics+makeStatistics = makeStatisticsUnsafe @a++makeStatisticsFast :: forall a ins out .  (Typeable a, Contains a out) => Registry ins out -> Statistics+makeStatisticsFast = makeStatisticsUnsafe @a++-- | Return `Statistics` as the result of the creation of a value+--   of a given type+makeStatisticsEither :: forall a ins out . (Typeable a) => Registry ins out -> Either Text Statistics+makeStatisticsEither registry =+  let values          = _values registry+      functions       = _functions registry+      specializations = _specializations registry+      modifiers       = _modifiers registry+      targetType      = someTypeRep (Proxy :: Proxy a)+  in+      -- 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+        evalStackWithValues values+          (makeUntyped targetType (Context [targetType]) functions specializations modifiers)++      of+        Left e ->+          Left $ "could not create a " <> show targetType <> " out of the registry because " <> e <> "\nThe registry is\n" <>+                 show registry++        other ->+          other++-- | Return `Statistics` as the result of the creation of a value+--   of a given type (and throws an exception if the value cannot be created)+makeStatisticsUnsafe  :: forall a ins out . (Typeable a) => Registry ins out -> Statistics+makeStatisticsUnsafe registry =+  case makeStatisticsEither @a registry of+    Right a -> a+    Left  e -> Prelude.error (toS e)

@@ -1,59 +1,43 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell       #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Data.Registry.DotSpec where -import           Data.Registry.Dot import           Data.Registry+import           Data.Text                                  as T import           Protolude-import Data.Text as T+import           Test.Data.Registry.Make.SpecializationSpec import           Test.Tasty.Extensions  test_dot =   prop "a dot graph can be generated from a registry" $ do-    let dot = makeDot @(IO Listener) registry+    let dot = makeDot @App appRegistry++    annotate "the graph does not contain redundant edges"+    annotate "the graph does not contain redundant edges"     unDot dot === T.unlines [-       "strict digraph {"-      ,"  node [shape=record]"-      ,"\"IO Test.Data.Registry.DotSpec.Listener\" -> \"Test.Data.Registry.DotSpec.ListenerConfig\\nListenerConfig nyc\";"-      ,"\"IO Test.Data.Registry.DotSpec.Listener\" -> \"IO Test.Data.Registry.DotSpec.Logging\";"-      ,"}"+        "strict digraph {"+      , "  node [shape=record]"+      , "\"Test.Data.Registry.Make.SpecializationSpec.App\" -> \"Test.Data.Registry.Make.SpecializationSpec.Sql-1\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.App\" -> \"Test.Data.Registry.Make.SpecializationSpec.TwitterClient\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.App\" -> \"Test.Data.Registry.Make.SpecializationSpec.Supervisor-1\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.App\" -> \"Test.Data.Registry.Make.SpecializationSpec.StatsStore\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.StatsStore\" -> \"Test.Data.Registry.Make.SpecializationSpec.TwitterClient\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.StatsStore\" -> \"Test.Data.Registry.Make.SpecializationSpec.Sql-2\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.StatsStore\" -> \"Test.Data.Registry.Make.SpecializationSpec.Supervisor-1\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.Supervisor-1\" -> \"Test.Data.Registry.Make.SpecializationSpec.SupervisorConfig-1\\nSupervisorConfig default\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.Sql-2\" -> \"Test.Data.Registry.Make.SpecializationSpec.Supervisor-2\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.Supervisor-2\" -> \"Test.Data.Registry.Make.SpecializationSpec.SupervisorConfig-2\\nSupervisorConfig for sql under the stats store\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.TwitterClient\" -> \"Test.Data.Registry.Make.SpecializationSpec.Supervisor-3\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.Supervisor-3\" -> \"Test.Data.Registry.Make.SpecializationSpec.SupervisorConfig-3\\nSupervisorConfig for the twitter client\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.Supervisor-1\" -> \"Test.Data.Registry.Make.SpecializationSpec.SupervisorConfig-1\\nSupervisorConfig default\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.TwitterClient\" -> \"Test.Data.Registry.Make.SpecializationSpec.Supervisor-3\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.Supervisor-3\" -> \"Test.Data.Registry.Make.SpecializationSpec.SupervisorConfig-3\\nSupervisorConfig for the twitter client\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.Sql-1\" -> \"Test.Data.Registry.Make.SpecializationSpec.Supervisor-4\";"+      , "\"Test.Data.Registry.Make.SpecializationSpec.Supervisor-4\" -> \"Test.Data.Registry.Make.SpecializationSpec.SupervisorConfig-4\\nSupervisorConfig for sql in general\";"+      , "}"       ] ---- * Helpers---- a registry--config =-     valTo @IO (AuthConfig "auth")-  +: valTo @IO (ListenerConfig "nyc")-  +: end--registry =-     fun       newLogging-  +: funTo @IO newAuth-  +: funAs @IO newListener-  +: config---- A small graph of components--newtype Logging = Logging { info :: Text -> IO () }--newLogging :: IO Logging-newLogging = pure (Logging print)--newtype Auth = Auth { auth :: Text -> IO Bool }-newtype AuthConfig = AuthConfig Text deriving (Eq, Show)--newAuth :: AuthConfig -> Logging -> Auth-newAuth _config _logging = Auth (\t -> print t >> pure True)--newtype Listener = Listener { listen :: Text -> IO () }-newtype ListenerConfig = ListenerConfig Text deriving (Eq, Show)--newListener :: ListenerConfig -> Logging -> IO Listener-newListener _config _logging = pure (Listener print)  ---- tests = $(testGroupGenerator)

@@ -4,7 +4,6 @@ module Test.Data.Registry.Internal.CacheSpec where  import           Control.Concurrent.Async-import           Data.IORef import           Data.Registry.Internal.Cache import           Protolude                    as P import           Test.Tasty.Extensions@@ -12,13 +11,13 @@ 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 <- newIORef (0 :: Int)-    let action = modifyIORef ref (+1) >> readIORef ref+    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 action-    _ <- replicateConcurrently_ 100 cachedAction -- with concurrent accesses+    void $ replicateConcurrently_ 100 cachedAction -- with concurrent accesses     cachedAction    cached === 1

@@ -13,6 +13,7 @@ import           Prelude                           (show) import           Protolude import           Type.Reflection+import           Data.List.NonEmpty  -- Hedgehog generators for the internal types registry =@@ -26,10 +27,12 @@   +: funTo @Gen ProvidedValue   +: funTo @Gen ValueDescription   +: funTo @Gen FunctionDescription+  +: funTo @Gen Specialization+  +: fun   (genNonEmpty @SomeTypeRep)   +: fun   (genList @(SomeTypeRep, Function))-  +: fun   (genList @(SomeTypeRep, Value))+  +: fun   (genList @Specialization)   +: fun   (genPair @SomeTypeRep @Function)-  +: fun   (genPair @SomeTypeRep @Value)+  +: fun   (genPair @(NonEmpty SomeTypeRep) @Value)   +: fun   (genList @Function)   +: fun   (genList @SomeTypeRep)   +: fun   (genList @Value)@@ -65,7 +68,7 @@   pure (value, values)  genSomeTypeRep :: Gen Value -> Gen SomeTypeRep-genSomeTypeRep = fmap (dynTypeRep . getValueDynamic)+genSomeTypeRep = fmap valueDynTypeRep  genDynamic :: Gen Dynamic genDynamic = Gen.element [toDyn (1 :: Int), toDyn (2 :: Int), toDyn ("1" :: Text)]@@ -75,6 +78,14 @@  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

@@ -1,6 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TypeApplications    #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -25,9 +23,9 @@    -- put one of the input types to build already in the list of   -- types being built-  let context = Context (target : _context context')+  let context = Context (target : _contextStack context') -  let result = runStack (makeInputs [target] context  functions specializations modifiers) values+  let result = runStackWithValues values (makeInputs [target] context  functions specializations modifiers)   case result of     Left e  -> annotateShow e >> "cycle detected!" `T.isPrefixOf` e === True     Right _ -> failure

@@ -30,7 +30,7 @@   values <- forAll $ gen @Values   let listTypeRep = dynTypeRep . toDyn $ [value]   let context = Context [listTypeRep] -- when trying to build a [Int]-  let specializations = Specializations [(listTypeRep, createValue value)]+  let specializations = Specializations [Specialization (pure listTypeRep) (createValue value)]    (fromValueDyn <$> findValue (valueDynTypeRep (createValue value)) context specializations values) === Just (Just value) @@ -52,7 +52,7 @@   (value, values) <- forAll genValues    let createdValue = createValue value-  let (Right stored) = execStack (storeValue mempty createdValue) values+  let (Right stored) = execStackWithValues values (storeValue mempty createdValue)    let found = findValue (dynTypeRep . toDyn $ value) mempty mempty stored   (fromValueDyn <$> found) === Just (Just value)@@ -63,7 +63,7 @@   let valueType = dynTypeRep . toDyn $ value   let modifiers = Modifiers [(valueType, createFunction (\(i:: Int) -> i + 1))]   let createdValue = createValue value-  let (Right stored) = execStack (storeValue modifiers createdValue) values+  let (Right stored) = execStackWithValues values (storeValue modifiers createdValue)    let found = findValue valueType mempty mempty stored   (fromValueDyn <$> found) === Just (Just (value + 1))@@ -77,7 +77,7 @@        , (valueType, createFunction (\(i:: Int) -> i + 1))        ]   let createdValue = createValue value-  let (Right stored) = execStack (storeValue modifiers createdValue) values+  let (Right stored) = execStackWithValues values (storeValue modifiers createdValue)    let found = findValue valueType mempty mempty stored   (fromValueDyn <$> found) === Just (Just ((value * 2) + 1))

@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.Internal.TypesSpec where++import           Data.List.NonEmpty+import           Data.Registry.Internal.Types+import           Protolude                    as P+import           Test.Tasty.Extensions+import           Type.Reflection++test_specialized_context_order = prop "there are preferrable specializations than other in a given context" $ do+  let c1 = Context [f, e, d, c, b, a]+  let s1 = specializedContext c1 (Specialization (a :| [c]) (createValue A))+  let s2 = specializedContext c1 (Specialization (a :| [e]) (createValue A))+  let s3 = specializedContext c1 (Specialization (c :| [f]) (createValue A))+  let s4 = specializedContext c1 (Specialization (b :| [f]) (createValue A))+  let s5 = specializedContext c1 (Specialization (pure c)   (createValue A))+  let s6 = specializedContext c1 (Specialization (pure f)   (createValue A))++  (s2 < s1) === True+  (s3 < s1) === True+  (s4 < s1) === True+  (s3 < s2) === True+  (s4 < s2) === True+  (s4 < s3) === True+  (s1 < s5) === True+  (s6 < s5) === True++data A = A deriving (Eq, Show)+data B = B deriving (Eq, Show)+data C = C deriving (Eq, Show)+data D = D deriving (Eq, Show)+data E = E deriving (Eq, Show)+data F = F deriving (Eq, Show)++a = someTypeRep $ typeOf A+b = someTypeRep $ typeOf B+c = someTypeRep $ typeOf C+d = someTypeRep $ typeOf D+e = someTypeRep $ typeOf E+f = someTypeRep $ typeOf F++----+tests = $(testGroupGenerator)

@@ -1,235 +0,0 @@-{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE TemplateHaskell  #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}--{--  This module tests the construction of some simple values-  using a registry--}-module Test.Data.Registry.Make where--import           Data.Registry-import           Data.Text     as T (length)-import           Data.IORef-import           Protolude hiding (C1)-import           Test.Tasty.Extensions-import           System.IO.Memoize----- | Contextual setting of different values for a given type-test_contextual = test "values can use some values depending on some context" $ do-  (c1, c2) <- liftIO $-    do let r =    val (Config 3)-               +: fun newUseConfig1-               +: fun newUseConfig2-               +: end-       let r' = specialize @UseConfig1 (Config 1) $-                specialize @UseConfig2 (Config 2) r-       pure (printConfig1 (make @UseConfig1 r'), printConfig2 (make @UseConfig2 r'))--  c1 === Config 1-  c2 === Config 2--newtype Config = Config Int deriving (Eq, Show)--newtype UseConfig1 = UseConfig1 { printConfig1 :: Config }-newUseConfig1 config = UseConfig1 { printConfig1 = config }--newtype UseConfig2 = UseConfig2 { printConfig2 :: Config }-newUseConfig2 config = UseConfig2 { printConfig2 = config }---- | Modification of stored values-test_tweak = test "created values can be modified prior to being stored" $ do-  c1 <- liftIO $-    do let r =    val (Config 1)-               +: fun newUseConfig1-               +: fun newAppUsingConfig1-               +: end-       let r' = tweak (\(UseConfig1 _) -> UseConfig1 (Config 10)) r-       pure (printConfig (make @AppUsingConfig1 r'))--  c1 === Config 10--newtype AppUsingConfig1 = AppUsingConfig1  { printConfig :: Config }-newAppUsingConfig1 config1 = AppUsingConfig1  { printConfig = printConfig1 config1 }---- | Creation of singletons with memoization-test_singleton = test "effectful values can be made as singletons 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 =    fun (argsTo @IO newC1)-               +: fun (argsTo @IO newC2)-               +: fun (argsTo @IO newSingOnce)-               +: end-       c1 <- make @(IO C1) r-       c2 <- make @(IO C2) r-       pure (c1, c2)--  c1 === C1 (Sing 1)-  c2 === C2 (Sing 1)--test_singleton_proper = test "effectful values can be made as singletons" $ do-  (c1, c2) <- liftIO $-    do -- create a counter for the number of instantiations-       counter <- newIORef 0--       let r =    fun (argsTo @IO newC1)-               +: fun (argsTo @IO newC2)-               +: fun (argsTo @IO (newSing counter))-               +: end-       r' <- singleton @IO @Sing r-       c1 <- make @(IO C1) r'-       c2 <- make @(IO C2) r'-       pure (c1, c2)--  c1 === C1 (Sing 1)-  c2 === C2 (Sing 1)--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)---- | Effectful creation with lifting-test_lifted = test "functions can be lifted in order to participate in building instances" $ do-  f1 <- liftIO $-    do let r =    fun (argsTo @IO newF1)-               +: valTo @IO (1::Int)-               +: valTo @IO ("hey"::Text)-               +: end-       make @(IO F1) r--  f1 === F1 1 "hey"--data F1 = F1 Int Text deriving (Eq, Show)--newF1 :: Int -> Text -> IO F1-newF1 i t = pure (F1 i t)--test_cycle = test "cycle can be detected" $ do-  -- a registry with 2 functions inverse of each other-  let explosive = makeUnsafe @Text (fun add1 +: fun dda1 +: end)-  r <- liftIO $ try (print explosive)-  case r of-    Left (_ :: SomeException) -> assert True-    Right _ -> assert False---- | No typeclass instance is necessary for a "record of functions" to be a Registry component-data Logging = Logging {-  info  :: Text -> IO ()-, debug :: Text -> IO ()-}--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)-newtype Text2 = Text2 Text deriving (Eq, Show)-newtype Int1 = Int1 Int deriving (Eq, Show)---- | values and functions-int1 :: Int-int1 = 1--add1 :: Int -> Text-add1 i = show (i + 1)--add2 :: Int -> Text -> Text1-add2 i j = Text1 (show (i+1) <> j)--text1 :: Text-text1 = "text1"--toText2 :: Text1 -> Text2-toText2 (Text1 t) = Text2 t--registry1 :: Registry (Inputs Int :++ '[Int, Int, Text, Text1])-                      '[Output Int, Text, Text1, Text2]-registry1 =-     val int1-  +: fun add1-  +: fun add2-  +: fun toText2-  +: end--countSize :: Text -> Maybe Int-countSize t = Just (T.length t)--m = make @Text $ fun (\(t::Text) -> t) +: end--made1 :: Text-made1 = make @Text registry1--made2 :: Text1-made2 = make @Text1 registry1--made3 :: Text2-made3 = make @Text2 registry1-----countSize1 :: Text -> Int1-countSize1 t = Int1 (T.length t)--registry2 :: Registry (Inputs Int :++ '[Int, Text]) '[Output Int, Text, Int1]-registry2 =-     fun int1-  +: fun add1-  +: fun countSize1-  +: end--made4 :: Int1-made4 = make @Int1 registry2---- | This does *not* compile because Double in not in the---   list of outputs for registry2-{--wrong :: Double-wrong = make @Double registry2--}---- | This does *not* compile because the list of inputs---   in registry2 is not included in the list of outputs-unknown :: Double -> Text1-unknown _ = Text1 "text1"--registry3 :: Registry (Inputs Int :++ '[Double, Int, Text])-                      '[Output Int, Text1, Text, Int1]-registry3 =-     val int1-  +: fun unknown-  +: fun add1-  +: fun countSize1-  +: end---- | This does not compile because we need a double---   to make Text1 and it is not in the list of outputs-{--wrong :: Text1-wrong = make @Text1 registry3--}---- | This version compiles but throws an exception at runtime-dangerous :: Text1-dangerous = makeUnsafe @Text1 registry3---- | This test shows that we can detect a cycle at runtime---- inverse of add1-dda1 :: Text -> Int-dda1 = T.length-------tests = $(testGroupGenerator)

@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.Make.MakeSpec where++import           Data.Registry+import           Data.Text             as T (length)+import           Protolude+import           Test.Tasty.Extensions++-- | Effectful creation with lifting+test_lifted = test "functions can be lifted in order to participate in building instances" $ do+  f1 <- liftIO $+    do let r =    fun (argsTo @IO newF1)+               +: valTo @IO (1::Int)+               +: valTo @IO ("hey"::Text)+               +: end+       make @(IO F1) r++  f1 === F1 1 "hey"++data F1 = F1 Int Text deriving (Eq, Show)++newF1 :: Int -> Text -> IO F1+newF1 i t = pure (F1 i t)++----++test_cycle = test "cycle can be detected" $ do+  -- a registry with 2 functions inverse of each other+  let explosive = makeUnsafe @Text (fun add1 +: fun dda1 +: end)+  r <- liftIO $ try (print explosive)+  case r of+    Left (_ :: SomeException) -> assert True+    Right _                   -> assert False++add1 :: Int -> Text+add1 i = show (i + 1)++-- inverse of add1 (in terms of type signature)+dda1 :: Text -> Int+dda1 = T.length++----+tests = $(testGroupGenerator)

@@ -0,0 +1,104 @@+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE TemplateHaskell  #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.Make.MemoizeSpec where++import           Data.Registry+import           Data.IORef+import           Protolude hiding (C1)+import           Test.Tasty.Extensions+import           System.IO.Memoize++-- | Creation of values with memoization+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 =    fun (argsTo @IO newC1)+               +: fun (argsTo @IO newC2)+               +: fun (argsTo @IO newSingOnce)+               +: end+       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 =    fun (argsTo @IO newC1)+               +: fun (argsTo @IO newC2)+               +: fun (argsTo @IO (newSing counter))+               +: end+       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)++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)++---++test_automatic_memoizeAll_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)+         +: end++    --  just instantiate the app for its effects+    withRegistry @App registry $ \_ _ -> pure ()++    ms <- liftIO $ readIORef messagesRef++    annotate "if memoize works properly, then only one warmup is invoked"+    ms === ["x"]++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 () }+  warmupWith (createWarmup (modifyIORef messagesRef ("x":) $> Ok ["good"]))+  pure c++data App = App { a :: A, b :: B }++++----+tests = $(testGroupGenerator)

@@ -0,0 +1,200 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.Make.SpecializationSpec where++import           Data.Registry+import           Protolude             hiding (C1)+import           Test.Tasty.Extensions++-- | Case 1: contextual setting of different values for a given type+test_specialization_1 = test "values can use other values depending on some context" $ do+  (c1, c2) <- liftIO $+    do let r =    val (Config 3)+               +: fun newUseConfig1+               +: fun newUseConfig2+               +: end+       let r' = specialize @UseConfig1 (Config 1) $+                specialize @UseConfig2 (Config 2) r+       pure (printConfig1 (make @UseConfig1 r'), printConfig2 (make @UseConfig2 r'))++  c1 === Config 1+  c2 === Config 2++-- | Case 2: if there are 2 specialization taking effect for 2 different types+--   the one that is the children of the other in the current context wins+test_specialization_2 = test "more specialized context" $ do+  c <- liftIO $+    do let r =    val (Config 3)+               +: fun newUseConfig+               +: fun newClient1+               +: end+       let r' = specialize @Client1 (Config 1) $+                specialize @UseConfig (Config 2) r+       pure $ printClientConfig1 (make @Client1 r')++  annotate "this is the more specialized context"+  c === Config 2++-- | Case 3: this time the specialization must "propagate" to components+--   using the specialized values, note that the `UseConfig` component needs to be+--   duplicated because it is on the path of the specialization+test_specialization_3 = test "specialized values must be kept up to their start context" $ do+  (c1, c2) <- liftIO $+    do let r =    val (Config 3)+               +: fun newUseConfig+               +: fun newClient1+               +: fun newClient2+               +: fun newBase+               +: end+       let r' = specialize @Client1 (Config 1) $+                specialize @Client2 (Config 2) r+       pure $ printBase (make @Base r')++  c1 === Config 1+  c2 === Config 2+++-- we want the following graph+{-+            +----------  Base  ------------++            |                              |+            v                              v+   (client1 :: Client1)          (client2 :: Client2)+            |                              |+            v                              v+   (useConfig1 :: UseConfig) (useConfig2 :: UseConfig)+            |                              |+            v                              v+   (config1 :: Config)           (config2 :: Config)+++-}++newtype Config = Config Int deriving (Eq, Show)++newtype UseConfig1 = UseConfig1 { printConfig1 :: Config }+newUseConfig1 config = UseConfig1 { printConfig1 = config }++newtype UseConfig2 = UseConfig2 { printConfig2 :: Config }+newUseConfig2 config = UseConfig2 { printConfig2 = config }++newtype UseConfig = UseConfig { printConfig :: Config }+newUseConfig config = UseConfig { printConfig = config }++newtype Client1 = Client1 { printClientConfig1 :: Config }+newClient1 useConfig = Client1 { printClientConfig1 = printConfig useConfig }++newtype Client2 = Client2 { printClientConfig2 :: Config }+newClient2 useConfig = Client2 { printClientConfig2 = printConfig useConfig }++newtype Base = Base { printBase :: (Config, Config) }+newBase client1 client2 = Base { printBase = (printClientConfig1 client1, printClientConfig2 client2) }++-- | Case 4: we can specialize values across a given "path" in the graph+test_specialization_4 = test "values can be specialized for a given path" $ do+  (c1, c2, c3) <- liftIO $+    do let r =    valTo @RIO (Config 3)+               +: funTo @RIO newUseConfig+               +: funTo @RIO newClient1+               +: funTo @RIO newClient2+               +: funTo @RIO newBase2+               +: end+       let r' = specializePathValTo @RIO @[RIO Base2, RIO Client1, RIO UseConfig] (Config 1) .+                specializeValTo @RIO @(RIO UseConfig) (Config 2) $ r++       printBase2 <$> (unsafeRun @Base2 r')++  c1 === Config 1+  c2 === Config 2+  c3 === Config 3++data Base2 = Base2 {+  client1   :: Client1+, useConfig :: UseConfig+, config3   :: Config+}+newBase2 = Base2++printBase2 Base2 {..} = (printClientConfig1 client1, printConfig useConfig, config3)++-- we want the following graph+{-+            +----------  Base2  -----------+-----> (config3 :: Config)+            |                              |+            v                              v+   (client1 :: Client1)        (useConfig2 :: UseConfig)+            |                              |+            v                              v+   (useConfig1 :: UseConfig)      (config2 :: Config)+            |+            v+   (config1 :: Config)+-}++-- | Case 5 (taken from a real case)+--   In that case a non-specialized value could be taken for a given+--   instead of being re-created because it has specialized dependencies for+--   a given context+--   For this test, we track how a component, the Supervisor, is being configured+--   depending on which path it belongs+test_specialization_5 = test "values can be specialized for a given path - other case" $ do+  let app = make @App appRegistry++  annotate "the stats store client is well configured"+  let (twitterConfig, statsSqlConfig, statsSupervisorConfig) = statsStoreConfig (statsStore app)+  twitterConfig         === "for the twitter client"+  statsSqlConfig        === "for sql under the stats store"+  statsSupervisorConfig === "default"++  annotate "the app is well configured"+  (app & supervisor & supervisorConfig) === ("default" :: Text)+  (app & sql & sqlConfig)               === ("for sql in general" :: Text)+++appRegistry :: Registry _ _+appRegistry =+  specializeUnsafeVal @Sql (SupervisorConfig "for sql in general") .+  specializePathUnsafeVal @[StatsStore, Sql] (SupervisorConfig "for sql under the stats store") .+  specializeUnsafeVal @TwitterClient (SupervisorConfig "for the twitter client") $+     val (SupervisorConfig "default")+  +: fun newTwitterClient+  +: fun newSupervisor+  +: fun newStatsStore+  +: fun newSql+  +: fun App+  +: end++data App = App {+  sql           :: Sql+, twitterClient :: TwitterClient+, supervisor    :: Supervisor+, statsStore    :: StatsStore+}++newtype Sql = Sql { sqlConfig :: Text }+newtype StatsStore  = StatsStore { statsStoreConfig :: (Text, Text, Text) } -- (twitter, sql, supervisor)+newtype TwitterClient = TwitterClient { twitterConfig :: Text }+newtype Supervisor = Supervisor { supervisorConfig :: Text }+newtype SupervisorConfig = SupervisorConfig Text deriving (Eq, Show)++newSupervisor :: SupervisorConfig -> Supervisor+newSupervisor (SupervisorConfig n) = Supervisor { supervisorConfig = n }++newSql :: Supervisor -> Sql+newSql s = Sql { sqlConfig = supervisorConfig s }++newTwitterClient :: Supervisor -> TwitterClient+newTwitterClient s = TwitterClient { twitterConfig = supervisorConfig s }++newStatsStore :: TwitterClient -> Sql -> Supervisor -> StatsStore+newStatsStore client sql supervisor = StatsStore {+  statsStoreConfig = (twitterConfig client, sqlConfig sql, supervisorConfig supervisor)+}++----+tests = $(testGroupGenerator)

@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE TemplateHaskell  #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.Make.TweakingSpec where++import           Data.Registry+import           Protolude+import           Test.Tasty.Extensions++-- | Modification of stored values+test_tweak = test "created values can be modified prior to being stored" $ do+  c1 <- liftIO $+    do let r =    val (Config 1)+               +: fun newUseConfig1+               +: fun newAppUsingConfig1+               +: end+       let r' = tweak (\(UseConfig1 _) -> UseConfig1 (Config 10)) r+       pure (printAppConfig (make @AppUsingConfig1 r'))++  c1 === Config 10++newtype AppUsingConfig1 = AppUsingConfig1  { printAppConfig :: Config }+newAppUsingConfig1 config1 = AppUsingConfig1  { printAppConfig = printConfig1 config1 }++newtype Config = Config Int deriving (Eq, Show)++newtype UseConfig1 = UseConfig1 { printConfig1 :: Config }+newUseConfig1 config = UseConfig1 { printConfig1 = config }++----+tests = $(testGroupGenerator)

@@ -36,4 +36,5 @@   content <- liftIO $ readIORef ref   content === ["start", "use", "close" :: Text] +---- tests = $(testGroupGenerator)

@@ -0,0 +1,110 @@+{-# LANGUAGE DataKinds        #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++{-+  These examples are simply provided to show what must compile+-}+module Test.Data.Registry.SimpleExamples where++import           Data.Registry+import           Data.Text     as T (length)+import           Protolude hiding (C1)+++-- | No typeclass instance is necessary for a "record of functions" to be a Registry component+data Logging = Logging {+  info  :: Text -> IO ()+, debug :: Text -> IO ()+}++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)+newtype Text2 = Text2 Text deriving (Eq, Show)+newtype Int1 = Int1 Int deriving (Eq, Show)++-- | values and functions+int1 :: Int+int1 = 1++add1 :: Int -> Text+add1 i = show (i + 1)++add2 :: Int -> Text -> Text1+add2 i j = Text1 (show (i+1) <> j)++text1 :: Text+text1 = "text1"++toText2 :: Text1 -> Text2+toText2 (Text1 t) = Text2 t++registry1 :: Registry (Inputs Int :++ '[Int, Int, Text, Text1])+                      '[Output Int, Text, Text1, Text2]+registry1 =+     val int1+  +: fun add1+  +: fun add2+  +: fun toText2+  +: end++countSize :: Text -> Maybe Int+countSize t = Just (T.length t)++m = make @Text $ fun (\(t::Text) -> t) +: end++made1 :: Text+made1 = make @Text registry1++made2 :: Text1+made2 = make @Text1 registry1++made3 :: Text2+made3 = make @Text2 registry1++--+countSize1 :: Text -> Int1+countSize1 t = Int1 (T.length t)++registry2 :: Registry (Inputs Int :++ '[Int, Text]) '[Output Int, Text, Int1]+registry2 =+     fun int1+  +: fun add1+  +: fun countSize1+  +: end++made4 :: Int1+made4 = make @Int1 registry2++-- | This does *not* compile because Double in not in the+--   list of outputs for registry2+{-+wrong :: Double+wrong = make @Double registry2+-}++-- | This does *not* compile because the list of inputs+--   in registry2 is not included in the list of outputs+unknown :: Double -> Text1+unknown _ = Text1 "text1"++registry3 :: Registry (Inputs Int :++ '[Double, Int, Text])+                      '[Output Int, Text1, Text, Int1]+registry3 =+     val int1+  +: fun unknown+  +: fun add1+  +: fun countSize1+  +: end++-- | This does not compile because we need a double+--   to make Text1 and it is not in the list of outputs+{-+wrong :: Text1+wrong = make @Text1 registry3+-}++-- | This version compiles but throws an exception at runtime+dangerous :: Text1+dangerous = makeUnsafe @Text1 registry3

@@ -6,10 +6,11 @@ module Test.Data.Registry.WarmupSpec where  import           Control.Monad.Catch-import           Prelude                (show)+import           Data.IORef+import           Data.Registry+import           Prelude               (show) import           Protolude import           Test.Tasty.Extensions-import           Data.Registry.Warmup  test_runBoth1 =   prop "all results are collected when running 2 warmup tasks" $ do@@ -23,7 +24,41 @@     r  <- liftIO $ throwM (Error "boom1") `runBoth` throwM (Error "boom2")     messages r === ["boom1", "boom2"] --- * helpers+test_run_side_effects_once =+  test "a component having a warmup must be memoized" $ do+    messagesRef <- liftIO $ newIORef []+    registry <-+       liftIO $ memoizeAll @RIO $+             funTo @RIO App+          +: funTo @RIO newA+          +: funTo @RIO newB+          +: fun   (newC messagesRef)+          +: end++    void $ withRIO (makeUnsafe @(RIO App) registry) $ const (pure ())++    ms <- liftIO $ readIORef messagesRef+    ms === ["x"]++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 () }+  warmupWith (createWarmup (modifyIORef messagesRef ("x":) $> Ok ["good"]))+  pure c++data App = App { a :: A, b :: B }++-- * HELPERS newtype Error = Error Text  instance Show Error where