registry (empty) → 0.1.0.0

raw patch · 31 files changed

+2402/−0 lines, 31 filesdep +asyncdep +basedep +exceptionssetup-changed

Dependencies added: async, base, exceptions, hedgehog, hedgehog-corpus, io-memoize, protolude, registry, resourcet, tasty, tasty-discover, tasty-hedgehog, tasty-th, text, transformers, transformers-base

Files

• LICENSE.txt +17/−0
• Setup.hs +4/−0
• registry.cabal +93/−0
• src/Data/Registry.hs +17/−0
• src/Data/Registry/Dot.hs +84/−0
• src/Data/Registry/Internal/Cache.hs +37/−0
• src/Data/Registry/Internal/Dynamic.hs +53/−0
• src/Data/Registry/Internal/Make.hs +108/−0
• src/Data/Registry/Internal/Operations.hs +71/−0
• src/Data/Registry/Internal/Reflection.hs +116/−0
• src/Data/Registry/Internal/Registry.hs +94/−0
• src/Data/Registry/Internal/Stack.hs +49/−0
• src/Data/Registry/Internal/Types.hs +151/−0
• src/Data/Registry/Lift.hs +63/−0
• src/Data/Registry/Make.hs +96/−0
• src/Data/Registry/RIO.hs +125/−0
• src/Data/Registry/Registry.hs +205/−0
• src/Data/Registry/Solver.hs +55/−0
• src/Data/Registry/Warmup.hs +109/−0
• test/Test/Data/Registry/DotSpec.hs +59/−0
• test/Test/Data/Registry/Internal/CacheSpec.hs +27/−0
• test/Test/Data/Registry/Internal/DynamicSpec.hs +51/−0
• test/Test/Data/Registry/Internal/Gens.hs +92/−0
• test/Test/Data/Registry/Internal/MakeSpec.hs +37/−0
• test/Test/Data/Registry/Internal/ReflectionSpec.hs +82/−0
• test/Test/Data/Registry/Internal/RegistrySpec.hs +89/−0
• test/Test/Data/Registry/Make.hs +235/−0
• test/Test/Data/Registry/SmallExample.hs +84/−0
• test/Test/Data/Registry/WarmupSpec.hs +43/−0
• test/Test/Tasty/Extensions.hs +55/−0
• test/test.hs +1/−0

@@ -0,0 +1,17 @@+Copyright (c) 2018 Eric Torreborre <etorreborre@yahoo.com>++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated +documentation files (the "Software"), to deal in the Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, +and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of +the Software. Neither the name of specs nor the names of its contributors may be used to endorse or promote +products derived from this software without specific prior written permission.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED+TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF+CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE.+

@@ -0,0 +1,4 @@+import           Distribution.Simple++main :: IO ()+main = defaultMain

@@ -0,0 +1,93 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 69724ea3bcc548733938f7f6e17f36c25bfcf15fe363bf71b446f0f7d0350137++name:           registry+version:        0.1.0.0+synopsis:       the Registry data structure can be used 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.+category:       Control+maintainer:     etorreborre@yahoo.com+license:        MIT+license-file:   LICENSE.txt+build-type:     Simple+cabal-version:  >= 1.10++source-repository head+  type: git+  location: https://github.com/etorreborre/registry++library+  exposed-modules:+      Data.Registry+      Data.Registry.Dot+      Data.Registry.Internal.Cache+      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.Types+      Data.Registry.Lift+      Data.Registry.Make+      Data.Registry.Registry+      Data.Registry.RIO+      Data.Registry.Solver+      Data.Registry.Warmup+  other-modules:+      Paths_registry+  hs-source-dirs:+      src+  default-extensions: FlexibleContexts FlexibleInstances LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings Rank2Types ScopedTypeVariables ScopedTypeVariables TupleSections TypeApplications TypeOperators+  ghc-options: -Wall -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path+  build-depends:+      base >=4.7 && <5+    , exceptions <0.11+    , protolude <0.3+    , resourcet <1.3+    , text <2+    , transformers <0.6+    , transformers-base <0.5+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: test.hs+  other-modules:+      Test.Data.Registry.DotSpec+      Test.Data.Registry.Internal.CacheSpec+      Test.Data.Registry.Internal.DynamicSpec+      Test.Data.Registry.Internal.Gens+      Test.Data.Registry.Internal.MakeSpec+      Test.Data.Registry.Internal.ReflectionSpec+      Test.Data.Registry.Internal.RegistrySpec+      Test.Data.Registry.Make+      Test.Data.Registry.SmallExample+      Test.Data.Registry.WarmupSpec+      Test.Tasty.Extensions+      Paths_registry+  hs-source-dirs:+      test+  default-extensions: FlexibleContexts FlexibleInstances LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings Rank2Types ScopedTypeVariables ScopedTypeVariables TupleSections TypeApplications TypeOperators+  ghc-options: -Wall -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures -optP-Wno-nonportable-include-path+  build-depends:+      async <2.3+    , base >=4.7 && <5+    , exceptions <0.11+    , hedgehog <0.7+    , hedgehog-corpus <0.2+    , io-memoize <1.2+    , protolude <0.3+    , registry+    , resourcet <1.3+    , tasty <1.2+    , tasty-discover <4.3+    , tasty-hedgehog <0.3+    , tasty-th <0.2+    , text <2+    , transformers <0.6+    , transformers-base <0.5+  default-language: Haskell2010

@@ -0,0 +1,17 @@+{- |++ Import this module if you want to access all the functionalities of the+ Registry API++-}+module Data.Registry (+  module M+) where++import Data.Registry.RIO      as M+import Data.Registry.Make     as M+import Data.Registry.Registry as M+import Data.Registry.Lift     as M+import Data.Registry.Solver   as M+import Data.Registry.Warmup   as M+import Data.Registry.Dot      as M

@@ -0,0 +1,84 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MonoLocalBinds      #-}++{- |+  This modules provides functions to extract+  a DOT graph (https://en.wikipedia.org/wiki/DOT_(graph_description_language)+  out of a Registry.+-}+module Data.Registry.Dot (+  module O+, 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.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+--   needed to build `a`+makeDot :: forall a ins out . (Typeable a, Contains a out, Solvable ins out)+  => Registry ins out+  -> Dot+makeDot = makeDotUnsafe @a++-- | Similar to `make` but does not check if `a` can be made out of the Regisry+--   You can use this version to get faster compilation times+makeDotFast :: forall a ins out . (Typeable a, Contains a out)+  => Registry ins out+  -> Dot+makeDotFast = makeDotUnsafe @a++-- | 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++-- | 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)

@@ -0,0 +1,37 @@+{- |++ Cache for individual IO values when we wish to make singletons+ for database connection pools for example++ This is inspired by https://hackage.haskell.org/package/io-memoize++-}+module Data.Registry.Internal.Cache where++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))+  deriving (Eq, Typeable)++-- | 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 =+  do m <- liftIO $ P.readMVar var+     case m of+       Just a -> pure a++       Nothing -> do+         val <- action+         liftIO $ modifyMVar_ var (\_ -> pure (Just val))+         pure val++-- | Create an empty cache.+newCache :: IO (Cache a)+newCache = do+  var <- P.newMVar Nothing+  return (Cache var)

@@ -0,0 +1,53 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++{- |+  Utility functions to work with Dynamic values+-}+module Data.Registry.Internal.Dynamic where++import           Data.Dynamic+import           Data.Registry.Internal.Types+import           Data.Text+import           Protolude+import           Type.Reflection++-- | Apply a function to a list of Dynamic values+applyFunction ::+     Function           -- function+  -> [Value]            -- inputs+  -> Either Text Value  -- result+applyFunction function values =+  do created <- applyFunctionDyn (funDyn function) (valueDyn <$> values)+     pure $ CreatedValue created (ValueDescription (_outputType . funDescription $ function) Nothing)++-- | Apply a Dynamic function to a list of Dynamic values+applyFunctionDyn+  :: Dynamic             -- function+  -> [Dynamic]            -- inputs+  -> Either Text Dynamic  -- result+applyFunctionDyn f [] =+  Left $  "the function "+         <> show (dynTypeRep f)+         <> " cannot be applied to an empty list of parameters"+applyFunctionDyn f [i     ] = applyOneParam f i+applyFunctionDyn f (i : is) = do+  f' <- applyOneParam f i+  applyFunctionDyn f' is++-- | Apply just one dynamic parameter to a dynamic function+applyOneParam :: Dynamic -> Dynamic -> Either Text Dynamic+applyOneParam f i =+  maybe (Left $ "failed to apply " <> show i <> " to : " <> show f) Right (dynApply f i)++-- | If Dynamic is a function collect all its input types+collectInputTypes :: Function -> [SomeTypeRep]+collectInputTypes = go . funDynTypeRep+ where+  go :: SomeTypeRep -> [SomeTypeRep]+  go (SomeTypeRep (Fun in1 out)) = SomeTypeRep in1 : go (SomeTypeRep out)+  go _                           = []++-- | If the input type is a function type return its output type+outputType :: SomeTypeRep -> SomeTypeRep+outputType (SomeTypeRep (Fun _ out)) = outputType (SomeTypeRep out)+outputType r                         = r

@@ -0,0 +1,108 @@+{-# LANGUAGE AllowAmbiguousTypes       #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE InstanceSigs              #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE PolyKinds                 #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE UndecidableInstances      #-}++{- |+  Untyped implementation of the functionalities in+    Data.Registry.Make+-}+module Data.Registry.Internal.Make where++import           Data.List                       hiding (unlines)+import           Data.Registry.Internal.Dynamic+import           Data.Registry.Internal.Registry+import           Data.Registry.Internal.Types+import           Data.Registry.Internal.Stack+import           Data.Text                       as T (unlines)+import           Protolude                       as P hiding (Constructor)+import           Type.Reflection++-- * WARNING: HIGHLY UNTYPED IMPLEMENTATION !++-- | Make a value from a desired output type represented by SomeTypeRep+--   and a list of possible constructors+--   A context is passed in the form of a stack of the types we are trying to build so far+--   We keep as a State value o+makeUntyped+  :: SomeTypeRep+  -> Context+  -> Functions+  -> Specializations+  -> Modifiers+  -> 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+    Nothing ->+      -- if not, is there a way to build such value?+      case findConstructor targetType functions of+        Nothing -> lift $ Left ("cannot find a constructor for " <> show targetType)++        Just function -> do+          let inputTypes = collectInputTypes function+          inputs <- makeInputs inputTypes context functions specializations modifiers++          if length inputs /= length inputTypes+            then+              let madeInputTypes = fmap valueDynTypeRep inputs+                  missingInputTypes = inputTypes \\ madeInputTypes+              in+                lift $ Left $+                  unlines+                $  ["could not make all the inputs for ", show (funDescription function), ". Only "]+                <> (show <$> inputs)+                <> ["could be made. Missing"]+                <> fmap show missingInputTypes+            else do+              v <- lift $ applyFunction function inputs+              modified <- storeValue modifiers v++              functionApplied modified inputs+              pure (Just modified)+++    Just v -> do+      modified <- storeValue modifiers v+      pure (Just modified)++-- | Make the input values of a given function+--   When a value has been made it is placed on top of the+--   existing registry so that it is memoized if needed in+--   subsequent calls+makeInputs+  :: [SomeTypeRep]   -- ^ input types to build+  -> Context         -- ^ current context of types being built+  -> Functions       -- ^ available functions to build values+  -> Specializations -- ^ list of values to use when in a specific context+  -> Modifiers       -- ^ modifiers to apply before storing made values+  -> Stack [Value]   -- list of made values+makeInputs [] _ _ _ _ = pure []++makeInputs (i : ins) (Context context) functions specializations modifiers =+  if i `elem` context+    then+      lift $ Left+      $  toS+      $  unlines+      $  ["cycle detected! The current types being built are "]+      <> (show <$> context)+      <> ["But we are trying to build again " <> show i]+    else do+      madeInput <- makeUntyped i (Context (i : context)) functions specializations modifiers+      case madeInput of+        Nothing ->+          -- if one input cannot be made, iterate with the rest for better reporting+          -- of what could be eventually made+          makeInputs ins (Context context) functions specializations modifiers++        Just v -> do+          (v :) <$> makeInputs ins (Context context) functions specializations modifiers

@@ -0,0 +1,71 @@+{- |+  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++-- | 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"

@@ -0,0 +1,116 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE TypeInType          #-}++{- |+  Utility functions to display types+-}+module Data.Registry.Internal.Reflection where++import           Data.Semigroup+import           Data.Text as T+import           Protolude       as P hiding (intercalate, TypeRep, isPrefixOf, (<>))+import           Type.Reflection+import           GHC.Exts++-- | Return true if the type of this type rep represents a function+isFunction :: SomeTypeRep -> Bool+isFunction d =+  case d of+    SomeTypeRep (Fun _ _) -> True+    _                     -> False++-- | Show the full type of a typeable value+showFullValueType :: Typeable a => a -> Text+showFullValueType = showTheFullValueType . typeOf++-- | Show the full type of a typeable function+showFullFunctionType :: Typeable a => a -> ([Text], Text)+showFullFunctionType = showTheFullFunctionType . typeOf++-- | Show the full type of a typeable value+--   where nested types like IO[Int] or functions are represented and+--   non GHC types are shown with their module names+showTheFullValueType :: forall (r1 :: RuntimeRep) (arg :: TYPE r1) . (TypeRep arg -> Text)+showTheFullValueType a =+  case a of+    Fun t1 t2 ->+      showTheFullValueType t1 <> " -> " <> showTheFullValueType t2++    Fun (App t1 t2) t3 ->+      showNested (SomeTypeRep t1) (SomeTypeRep t2) <> " -> " <> showTheFullValueType t3++    App t1 t2 ->+      showNested (SomeTypeRep t1) (SomeTypeRep t2)++    _ ->+      showSingleType (SomeTypeRep a)++-- | Show the full type of a typeable value+--   where nested types like IO[Int] or functions are represented and+--   non GHC types are shown with their module names+showTheFullFunctionType :: forall (r1 :: RuntimeRep) (arg :: TYPE r1) . (TypeRep arg -> ([Text], Text))+showTheFullFunctionType a =+  case a of+    Fun t1 t2 ->+      let in1 = showTheFullValueType t1+          (ins, out) = showTheFullFunctionType t2+      in  (in1 : ins, out)++    Fun (App t1 t2) t3 ->+      let (ins, out) = showTheFullFunctionType t3+      in  (showNested (SomeTypeRep t1) (SomeTypeRep t2) : ins, out)++    App t1 t2 ->+      ([], showNested (SomeTypeRep t1) (SomeTypeRep t2))++    _ ->+      ([], showSingleType (SomeTypeRep a))++-- | Show a type like m a+showNested :: SomeTypeRep -> SomeTypeRep -> Text+showNested a b =+  parenthesizeNested $ tweakNested $ showSingleType a <> " " <> showSingleType b++-- | Show a single type. Don't display the module for GHC types+showSingleType :: SomeTypeRep -> Text+showSingleType a =+  let withModuleName = showWithModuleName a+  in  if mustShowModuleName withModuleName+      then withModuleName+      else show a++-- | Return true if the module name can be shown+mustShowModuleName :: Text -> Bool+mustShowModuleName name = not $ P.any identity $+  fmap (`isPrefixOf` name) [+      "GHC.Types."    -- for Int, Double,..+    , "GHC.Base."     -- for Maybe+    , "Data.Either."  -- for Either+    , "Data.Text.Internal"]++-- | Tweak some standard module names for better display+tweakNested :: Text -> Text+tweakNested "[] Char" = "String"+tweakNested n =+  if "[] " `isPrefixOf` n then+    "[" <> T.drop 3 n <> "]" -- special processing for lists+  else+    n++-- | This is an attempt to better render "nested" types like IO (Maybe Text)+--   The input value is "IO Maybe Text" and the output text will be "IO (Maybe Text)"+--   This will unfortunately not work with types having several type parameters+--   like IO (Either Text Int)+parenthesizeNested :: Text -> Text+parenthesizeNested t =+  case T.splitOn " " t of+    [] -> t+    [_] -> t+    [outer, inner] -> outer <> " " <> inner+    outer : rest -> outer <> " (" <> parenthesizeNested (T.intercalate " " rest) <> ")"++-- | Show a type with its module name+showWithModuleName :: SomeTypeRep -> Text+showWithModuleName t = (toS . tyConModule . someTypeRepTyCon $ t) <> "." <> show t

@@ -0,0 +1,94 @@+{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE MonoLocalBinds             #-}+{-# LANGUAGE UndecidableInstances       #-}++{- |+  Internal structure of a registry and+  associated functions+-}+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           Type.Reflection++-- | Find a value having a target type+--   from a list of dynamic values found in a list of constructors+--   where some of them are not functions+--   There is also a list of specializations when we can specialize the values to use+--   if a given type is part of the context+findValue+  :: SomeTypeRep+  -> Context+  -> Specializations+  -> Values+  -> Maybe Value+-- no specializations or constructors to choose from+findValue _ _ (Specializations []) (Values []) = Nothing++-- 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++-- 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)++-- | Find a constructor function returning a target type+--   from a list of constructorsfe+findConstructor+  :: SomeTypeRep+  -> Functions+  -> Maybe Function+findConstructor _      (Functions []        ) = Nothing+findConstructor target (Functions (f : rest)) =+  case funDynTypeRep f of+    SomeTypeRep (Fun _ out) ->+      if outputType (SomeTypeRep out) == target then+        Just f+      else+        findConstructor target (Functions rest)++    _ ->+      findConstructor target (Functions rest)++-- | Given a newly built value, check if there are modifiers for that+--   value and apply them before "storing" the value which means+--   adding it on top of the registry, represented by the `Values` state+--   in StateT Values.+--   We use a StateT Either because applying modifiers could fail and we want+--   to catch and report the error. Note that this error would be an implementation+--   error (and not a user error) since at the type-level everything should be correct+--+storeValue+  :: Modifiers+  -> Value+  -> Stack Value+storeValue (Modifiers ms) value =+  let modifiers = findModifiers ms++  in  do valueToStore <- modifyValue value modifiers+         modifyValues (addValue valueToStore)+         pure valueToStore+  where+    -- find the applicable modifiers+    findModifiers = filter (\(m, _) -> valueDynTypeRep value == m)++    -- apply a list of modifiers to a value+    modifyValue :: Value -> [(SomeTypeRep, Function)] -> Stack Value+    modifyValue v [] = pure v+    modifyValue v ((_, f) : rest) = do+      applied <- lift $ applyFunction f [v]+      modifyValue applied rest

@@ -0,0 +1,49 @@+{- |+  Internal monad for the resolution algorithm++   - we keep some state for the list of created values+   - we collect the applied functions as "Operations"+   - we might exit with a Left value if we can't build a value++-}+module Data.Registry.Internal.Stack where++import           Data.Registry.Internal.Operations+import           Data.Registry.Internal.Types+import           Protolude++-- | Monadic stack for the resolution algorithm+type Stack a = StateT (Values, Operations) (Either Text) a++-- | Return a value from the Stack if possible+runStack :: Stack a -> Values -> Either Text a+runStack sa vs = evalStateT sa (vs, [])++-- | 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, [])++-- | Return the list of applied functions after resolution+evalStack :: Stack a -> Values -> Either Text Operations+evalStack sa vs = snd <$> execStateT sa (vs, [])++-- | Get the current list of values+getValues :: Stack Values+getValues = fst <$> get++-- | Get the current list of operations+getOperation :: Stack Operations+getOperation = snd <$> get++-- | Modify the current list of values+modifyValues :: (Values -> Values) -> Stack ()+modifyValues f = modify (\(vs, ops) -> (f vs, ops))++-- | Get the current list of values+modifyOperations :: (Operations -> Operations) -> Stack ()+modifyOperations f = modify (\(vs, ops) -> (vs, f ops))++-- | Store a function application in the list of operations+functionApplied :: Value -> [Value] -> Stack ()+functionApplied output inputs = modifyOperations (AppliedFunction output inputs:)

@@ -0,0 +1,151 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+  List of types used inside the Registry+-}+module Data.Registry.Internal.Types where++import           Data.Dynamic+import           Data.Registry.Internal.Reflection+import           Data.Text                         as T+import           Prelude                           (show)+import           Protolude                         hiding (show)+import           Type.Reflection++-- | A Function is the Dynamic representation of a Haskell value + its description+--   It is either provided by the user of the Registry or created as part of the+--   resolution algorithm+data Value =+    CreatedValue  Dynamic ValueDescription+  | ProvidedValue Dynamic ValueDescription+  deriving (Show)++-- | 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)++-- | 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)++-- | Describe a value with only its type+describeTypeableValue :: (Typeable a) => a -> ValueDescription+describeTypeableValue a = ValueDescription (showFullValueType a) Nothing++-- | Show a Value from the Registry+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, with only its Typeable description+createTypeableValue :: Typeable a => a -> Value+createTypeableValue a = ProvidedValue (toDyn a) (describeTypeableValue a)++-- | Create a Value from a Dynamic value and some description+createDynValue :: Dynamic -> Text -> Value+createDynValue dyn desc = ProvidedValue dyn (ValueDescription desc Nothing)++-- | Type representation of a Value+valueDynTypeRep :: Value -> SomeTypeRep+valueDynTypeRep (CreatedValue  d _) = dynTypeRep d+valueDynTypeRep (ProvidedValue d _) = dynTypeRep d++-- | Dynamic representation of a Value+valueDyn :: Value -> Dynamic+valueDyn (CreatedValue  d _) = d+valueDyn (ProvidedValue d _) = d++-- | The description for a Value+valDescription :: Value -> ValueDescription+valDescription (CreatedValue  _ d) = d+valDescription (ProvidedValue _ d) = d++-- | 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++-- | A Function is the Dynamic representation of a Haskell function + its description+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)++-- | Description of a function with input types and output type+data FunctionDescription = FunctionDescription {+    _inputTypes :: [Text]+  , _outputType :: Text+  } deriving (Eq, Show)++-- | Describe a function (which doesn't have a Show instance)+--   that can be put in the Registry+describeFunction :: Typeable a => a -> FunctionDescription+describeFunction = uncurry FunctionDescription . showFullFunctionType++-- | Show a Function as Text using its Description+showFunction :: Function -> Text+showFunction = funDescriptionToText . funDescription++-- | The Description of a Function+funDescription :: Function -> FunctionDescription+funDescription (Function _ t) = t++-- | Dynamic representation of a Function+funDyn :: Function -> Dynamic+funDyn (Function d _) = d++-- | Type representation of a Function+funDynTypeRep :: Function -> SomeTypeRep+funDynTypeRep = dynTypeRep . funDyn++-- | A FunctionDescription as Text+funDescriptionToText :: FunctionDescription -> Text+funDescriptionToText (FunctionDescription ins out) = T.intercalate " -> " (ins <> [out])++-- | Return True if a Function has some input values+hasParameters :: Function -> Bool+hasParameters = isFunction . funDynTypeRep++-- | A Typed value can be added to a Registry+--   It is either a value, having both Show and Typeable information+--   or a function having just Typeable information+data Typed a =+    TypedValue Value+  | TypedFunction Function++-- The list of functions available for constructing other values+newtype Functions = Functions [Function] deriving (Show, Semigroup, Monoid)++-- | Add one more Function to the list of Functions+addFunction :: Function -> Functions -> Functions+addFunction f (Functions fs) = Functions (f : fs)++-- | List of values available for constructing other values+newtype Values = Values [Value] deriving (Show, Semigroup, Monoid)++-- | Add one more Value to the list of Values+addValue :: Value -> Values -> Values+addValue v (Values vs) = Values (v : vs)++-- | The types of values being currently built+newtype Context = Context { _context :: [SomeTypeRep] } deriving (Show, Semigroup, Monoid)++-- | Specification of values which become available for+--   construction when a corresponding type comes in context+newtype Specializations = Specializations [(SomeTypeRep, Value)] deriving (Show, Semigroup, Monoid)++-- | 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)

@@ -0,0 +1,63 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE IncoherentInstances   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{- |+  This code is taken from https://stackoverflow.com/questions/28003135/is-it-possible-to-encode-a-generic-lift-function-in-haskell+  to allow a generic lift operation over an Applicative context+  So if you have a function: Int -> Text -> IO Int, it can be lifted to have all of its parameters+    in IO:++    f :: Int -> Text -> IO Int++    lifted :: IO Int -> IO Text -> IO Int+    lifted = to @IO f++-}+module Data.Registry.Lift where++import           Protolude++-- | Typeclass for lifting pure functions to effectful arguments and results+class Applicative f => ApplyVariadic f a b where+  applyVariadic :: f a -> b++instance (Applicative f, b ~ f a) => ApplyVariadic f a b where+  applyVariadic = identity++instance (Applicative f, ApplyVariadic f a' b', b ~ (f a -> b')) => ApplyVariadic f (a -> a') b where+  applyVariadic f fa = applyVariadic (f <*> fa)++-- | Lift a pure function to effectful arguments and results+allTo :: forall f a b. ApplyVariadic f a b => a -> b+allTo a = (applyVariadic :: f a -> b) (pure a)++-- | Typeclass for lifting impure functions to effectful arguments and results+class Monad f => ApplyVariadic1 f a b where+  applyVariadic1 :: f a -> b++instance (Monad f, b ~ f a) => ApplyVariadic1 f (f a) b where+  applyVariadic1 = join++instance (Monad f, ApplyVariadic1 f a' b', b ~ (f a -> b')) => ApplyVariadic1 f (a -> a') b where+  applyVariadic1 f fa = applyVariadic1 (f <*> fa)++-- | Lift an effectful function to effectful arguments and results+argsTo :: forall f a b . ApplyVariadic1 f a b => a -> b+argsTo a = (applyVariadic1 :: f a -> b) (pure a)++-- | Typeclass for lifting a function with a result of type m b into a function+--   with a result of type n b+class Applicative f => ApplyVariadic2 f g a b where+  applyVariadic2 :: (forall x . f x -> g x) -> a -> b++instance (Applicative f, b ~ g a) => ApplyVariadic2 f g (f a) b where+  applyVariadic2 natfg = natfg++instance (Applicative f, ApplyVariadic2 f g a' b', b ~ (a -> b')) => ApplyVariadic2 f g (a -> a') b where+  applyVariadic2 natfg f a = applyVariadic2 natfg (f a)++-- | Lift a function returning an effectful result to a function returning another effectful result+outTo :: forall g f a b . ApplyVariadic2 f g a b => (forall x . f x -> g x) -> a -> b+outTo natfg = applyVariadic2 natfg :: a -> b

@@ -0,0 +1,96 @@+{-# LANGUAGE AllowAmbiguousTypes       #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE InstanceSigs              #-}+{-# LANGUAGE PolyKinds                 #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE UndecidableInstances      #-}++{- |+  This module provides functions to make values+  out of a registry. The general algorithm is the following++   1. for a given value type search in the existing list of values+      a value with the same type. If found return it++   2. if not found search a function having the desired output type+      if found, now try to recursively make all the input parameters.+      Keep a context of the current type trying to be built.++   3. when trying to make an input parameter if the current input type+      is already in the types trying to be built then there is a cycle.+      Throw an exception in that case++   4. when a value has been constructed place it on top of the existing value+      list so that it can be reused by other functions++-}+module Data.Registry.Make where++import           Data.Dynamic+import           Data.Registry.Internal.Make+import           Data.Registry.Internal.Stack+import           Data.Registry.Internal.Types+import           Data.Registry.Registry+import           Data.Registry.Solver+import           Data.Typeable                   (Typeable)+import qualified Prelude                         (error)+import           Protolude                       as P hiding (Constructor)+import           Type.Reflection++-- | For a given registry make an element of type a+--   We want to ensure that a is indeed one of the return types+--   We also try to statically check if there aren't other possible errors+make+  :: forall a ins out+   . (Typeable a, Contains a out, Solvable ins out)+  => Registry ins out+  -> a+make = makeUnsafe++-- | Same as make but without the solvable constraint to compile faster+--   in tests for example+makeFast+  :: forall a ins out+   . (Typeable a, Contains a out)+  => Registry ins out+  -> a+makeFast = makeUnsafe++-- | This version of make only execute checks at runtime+--   this can speed-up compilation when writing tests or in ghci+makeEither :: forall a ins out . (Typeable a) => Registry ins out -> Either Text a+makeEither 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 runStack) 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++        Right Nothing ->+          Left $ "could not create a " <> show targetType <> " out of the registry." <> "\nThe registry is\n" <>+                 show registry++        Right (Just result) -> fromMaybe+          (Left $ "could not cast the computed value to a " <> show targetType <> ". The value is of type: " <> show (valueDynTypeRep result))+          (Right <$> fromDynamic (valueDyn result))++-- | This version of make only execute checks at runtime+--   this can speed-up compilation when writing tests or in ghci+makeUnsafe :: forall a ins out . (Typeable a) => Registry ins out -> a+makeUnsafe registry =+  case makeEither registry of+    Right a -> a+    Left  e -> Prelude.error (toS e)

@@ -0,0 +1,125 @@+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE IncoherentInstances   #-}+{-# LANGUAGE MonoLocalBinds        #-}+{-# LANGUAGE UndecidableInstances  #-}+{- |++  RIO is equivalent to ResourceT (WriterT Warmup IO)+  It can be used to instantiate "modules as records of functions"+  where each module can allocate resources and have a "warmup phase"+  to preload data or asses if it is working properly++-}+module Data.Registry.RIO where++import           Control.Monad.Base+import           Control.Monad.Catch+import           Control.Monad.Trans.Resource+import qualified Control.Monad.Trans.Resource as Resource (allocate)++import           Data.Registry.Make+import           Data.Registry.Registry+import           Data.Registry.Solver+import           Data.Registry.Warmup+import           Protolude++-- | Data type encapsulating resource finalizers+newtype Stop = Stop InternalState++-- | Run all finalizers+runStop :: Stop -> IO ()+runStop (Stop is) = runResourceT $ closeInternalState is++-- | This newtype creates a monad to sequence+--   module creation actions, cumulating start/stop tasks+--   found along the way+newtype RIO a =+  RIO+  { runRIO :: Stop -> IO (a, Warmup) }+  deriving (Functor)++instance Applicative RIO where+  pure a =+    RIO (const (pure (a, mempty)))++  RIO fab <*> RIO fa =+    RIO $ \s ->+      do (f, sf) <- fab s+         (a, sa) <- fa s+         pure (f a, sf `mappend` sa)++instance Monad RIO where+  return = pure++  RIO ma >>= f =+    RIO $ \s ->+      do (a, sa) <- ma s+         (b, sb) <- runRIO (f a) s+         pure (b, sa `mappend` sb)++instance MonadIO RIO where+  liftIO io = RIO (const $ (, mempty) <$> io)++instance MonadThrow RIO where+  throwM e = RIO (const $ throwM e)++instance MonadBase IO RIO where+  liftBase = liftIO++instance MonadResource RIO where+  liftResourceT action = RIO $ \(Stop s) -> liftIO ((, mempty) <$> runInternalState action s)++-- * For production++-- | This function must be used to run services involving a top module+--   It creates the top module and invokes all warmup functions+--+--   The passed function 'f' is used to decide whether to continue or+--   not depending on the Result+withRegistry :: forall a b ins out . (Typeable a, Contains (RIO a) out, Solvable ins out) =>+     Registry ins out+  -> (Result -> a -> IO b)+  -> IO b+withRegistry registry f = runResourceT $ do+  (a, warmup) <- runRegistryT @a registry+  result      <- lift $ 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)++-- * For testing++-- | Instantiate the component but don't execute the warmup (it may take time)+--   and keep the Stop value to clean resources later+--   This function statically checks that the component can be instantiated+executeRegistry :: forall a ins out . (Typeable a, Contains (RIO a) out, Solvable ins out) => Registry ins out -> IO (a, Warmup, Stop)+executeRegistry registry = do+  is <- 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 registry = fst <$> unsafeRunWithStop registry++-- | Same as unsafeRun but keep the Stop value to be able to clean resources later+unsafeRunWithStop :: forall a ins out . (Typeable a, Contains (RIO a) out) => Registry ins out -> IO (a, Stop)+unsafeRunWithStop registry = do+  is <- createInternalState+  (a, _) <- runRIO (makeUnsafe @(RIO a) registry) (Stop is)+  pure (a, Stop is)++-- * Module creation++-- | Lift a warmup action into the RIO monad+warmupWith :: Warmup -> RIO ()+warmupWith w = RIO (const $ pure ((), w))++-- | Allocate some resource+allocate :: IO a -> (a -> IO ()) -> RIO a+allocate resource cleanup =+  snd <$> Resource.allocate resource cleanup

@@ -0,0 +1,205 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MonoLocalBinds        #-}+{-# LANGUAGE UndecidableInstances  #-}++{- |+  A registry supports the creation of values out of existing values and+  functions.++  It contains 4 parts:+   - values: they are available for building anything else and have their exact value can be shown+   - functions: they are used to build other values. Only their type can be shown+   - specializations: description of specific values to use while trying to build another value of a given type+   - modifiers: function to apply to a newly built value before storing it for future use++  A registry is created by using the +: operator, adding functions or values to the empty `end` registry:++    registry =+         val (Config 1)+      +: val "hello"+      +: fun add1+      +: fun show1+      +: end++  At the type level a list of all the function inputs and all the outputs is being kept to+  allow some checks to be made when we want to build a value out of the registry.++  Registries have a `Monoid` instance so they can be created incrementally:++    config =+         val (Config 1)+      +: val "hello"+      +: end++    constructors =+      +: fun add1+      +: fun show1+      +: end++    registry =+      config <> constructors++  It is also possible to use the `<>` operator to "override" some configurations:++    mocks =+         fun noLogging+      +: fun inMemoryDb+      +: end++    mocks <> registry++-}+module Data.Registry.Registry where++import           Data.Registry.Internal.Cache+import           Data.Registry.Internal.Types+import           Data.Registry.Lift+import           Data.Registry.Solver+import           Data.Dynamic+import           Data.Semigroup             ((<>))+import           Data.Text                  as T (unlines)+import           Data.Typeable              (Typeable)+import qualified Prelude                    (show)+import           Protolude                  as P hiding ((<>))+import           Type.Reflection++-- | Container for a list of functions or values+--   Internally all functions and values are stored as Dynamic values+--   so that we can access their representation+data Registry (inputs :: [*]) (outputs :: [*]) =+  Registry {+    _values          :: Values+  , _functions       :: Functions+  , _specializations :: Specializations+  , _modifiers       :: Modifiers+  }++instance Show (Registry inputs outputs) where+  show (Registry (Values vs) (Functions fs) _ _) =+    let describeValues =+          if null vs then ""+          else            unlines (valDescriptionToText . valDescription <$> vs)+        describeFunctions =+            if null fs then ""+            else            unlines (funDescriptionToText . funDescription <$> fs)+    in+        toS $ unlines [describeValues, describeFunctions]++instance Semigroup (Registry inputs outputs) => Monoid (Registry inputs outputs) where+  mempty = Registry (Values []) (Functions []) (Specializations []) (Modifiers [])+  mappend = (<>)++-- | Append 2 registries together+(<+>) :: Registry is1 os1 -> Registry is2 os2 -> Registry (is1 :++ is2) (os1 :++ os2)+(<+>) (Registry (Values vs1) (Functions fs1) (Specializations ss1) (Modifiers ms1))+       (Registry (Values vs2) (Functions fs2) (Specializations ss2) (Modifiers ms2))  =+          Registry (Values (vs1 <> vs2)) (Functions (fs1 <> fs2)) (Specializations (ss1 <> ss2)) (Modifiers (ms1 <> ms2))++-- | Store an element in the registry+--   Internally elements are stored as dynamic values+register :: (Typeable a)+  => Typed a+  -> Registry ins out+  -> Registry (Inputs a :++ ins) (Output a ': out)+register (TypedValue v) (Registry (Values vs) functions specializations modifiers) =+  Registry (Values (v : vs)) functions specializations modifiers++register (TypedFunction f) (Registry (Values vs) (Functions fs) specializations modifiers) =+  if hasParameters f then+    Registry (Values vs) (Functions (f : fs)) specializations modifiers+  else+    Registry (Values (createDynValue (funDyn f) (showFunction f) : vs)) (Functions fs) specializations modifiers++-- | Add an element to the Registry - Alternative to register where the parentheses can be ommitted+infixr 5 +:+(+:) :: (Typeable a) => Typed a -> Registry ins out -> Registry (Inputs a :++ ins) (Output a ': out)+(+:) = register++-- | The empty Registry+end :: Registry '[] '[]+end = Registry (Values []) (Functions []) (Specializations []) (Modifiers [])++-- | Create a value which can be added to the Registry+val :: (Typeable a, Show a) => a -> Typed a+val a = TypedValue (ProvidedValue (toDyn a) (describeValue a))++-- | Create a value which can be added to the Registry and "lift" it to an Applicative context+valTo :: forall m a . (Applicative m, Typeable a, Typeable (m a), Show a) => a -> Typed (m a)+valTo a = TypedValue (liftProvidedValue @m a)++-- | Create a "lifted" a Value+liftProvidedValue :: forall m a . (Applicative m, Typeable a, Typeable (m a), Show a) => a -> Value+liftProvidedValue a = ProvidedValue (toDyn (pure a :: m a)) (describeValue a)++-- | Create a function which can be added to the Registry+fun :: (Typeable a) => a -> Typed a+fun a = TypedFunction (createFunction a)++-- | This is a shortcut to (fun . allTo) where `allTo` lifts all the inputs and output+--   to an Applicative context+funTo :: forall m a b . (ApplyVariadic m a b, Typeable a, Typeable b) => a -> Typed b+funTo a = fun (allTo @m a)++-- | This is a shortcut to (fun . argsTo) where `allTo` lifts all the inputs+--   to an Applicative context+funAs :: forall m a b . (ApplyVariadic1 m a b, Typeable a, Typeable b) => a -> Typed b+funAs a = fun (argsTo @m a)++-- | For a given type `a` being currently built+--   when a value of type `b` is required pass a specific+--   value+specialize :: forall a b ins out . (Typeable a, Contains a out, Typeable b)+  => b+  -> Registry ins out+  -> Registry ins out+specialize b (Registry values functions (Specializations c) modifiers) = Registry+  values+  functions+  (Specializations ((someTypeRep (Proxy :: Proxy a), createTypeableValue b) : c))+  modifiers++-- | 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)+  => b+  -> Registry ins out+  -> Registry ins out+specializeVal b (Registry values functions (Specializations c) modifiers) = Registry+  values+  functions+  (Specializations ((someTypeRep (Proxy :: Proxy a), createValue b) : c))+  modifiers++-- | This is similar to specialize but additionally uses the Show instance of b+--   to display more information when printing the registry out and+--   it "lifts" the value to an applicative context+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 b (Registry values functions (Specializations c) modifiers) = Registry+  values+  functions+  (Specializations ((someTypeRep (Proxy :: Proxy a), liftProvidedValue @m b) : c))+  modifiers++-- | Once a value has been computed allow to modify it before storing+--   it+tweak :: forall a ins out . (Typeable a, Contains a out)+  => (a -> a)+  -> Registry ins out+  -> Registry ins out+tweak 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+--   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)+  => Registry ins out+  -> IO (Registry ins out)+singleton r = do+  cache <- newCache @a+  pure $ tweak @(m a) (fetch cache) r

@@ -0,0 +1,55 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{- |+  Type level functions to statically assess+  if a value can be built out of a Registry++  For now we don't check if there could be cycles in+    the registry functions+-}+module Data.Registry.Solver where++import           Data.Kind+import           GHC.TypeLits++-- | Compute the list of input types for a function+type family Inputs f :: [*] where+  Inputs (i -> o) = i ': Inputs o+  Inputs x = '[]++-- | Compute the output type for a function+type family Output f :: * where+  Output (i -> o) = Output o+  Output x = x++-- | Compute if a type is contained in a list of types+type family Contains (a :: *) (els :: [*]) :: Constraint where+  Contains a '[] = TypeError ('Text "No element of type " ':<>: 'ShowType a ':<>: 'Text " can be build out of the registry")+  Contains a (a ': els) = ()+  Contains a (b ': els) = Contains a els++-- | Shorthand type alias when many such constraints need to be added to a type signature+type (out :- a) = Contains a out++-- | Compute if each element of a list of types is contained in+-- another list+class IsSubset (ins :: [*]) (out :: [*])+instance IsSubset '[] out+instance (Contains a out, IsSubset els out) => IsSubset (a ': els) out++-- | From the list of all the input types and outputs types of a registry+--   Can we create all the output types?+class Solvable (ins :: [*]) (out :: [*])+instance (IsSubset ins out) => Solvable ins out+++-- | Extracted from the typelevel-sets project and adapted for the Registry datatype+-- | This union deduplicates elements only+--   if they appear in contiguously:+type family (:++) (x :: [k]) (y :: [k]) :: [k] where+  '[]       :++ xs = xs+  (x ': xs) :++ ys = x ': (xs :++ ys)

@@ -0,0 +1,109 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+  This module contains data structures to describe the+  "warming-up" of componnts in order to ensure that they+   are properly configured:++   - createWarmup creates a warmup from an action+     returning a Result++   - warmupOf takes a component name and unit action+     then just checks that the action executes without+     exception+-}+module Data.Registry.Warmup where++import qualified Control.Monad.Catch as Catch+import           Data.Semigroup      ((<>))+import           Protolude           as P hiding ((<>))+import           Data.Typeable++-- | A list of actions to run at startup+newtype Warmup =+  Warmup+  { _warmUp :: [IO Result]+  } deriving (Monoid, Semigroup)++-- * Creation functions++-- | Create a warmup action for a given module+--   The type of the module is used as the description for+--   the action to execute+warmupOf :: Typeable a => a -> IO () -> Warmup+warmupOf a action = createWarmup $+  do res <- Catch.try action :: IO (Either SomeException ())+     pure $+       case res of+         Left e  -> failed $ "KO: " <> show (typeOf a) <> " -> " <> show e+         Right _ -> ok $ "OK: " <> show (typeOf a)++-- | Create a Warmup from an IO action returning a Result+createWarmup :: IO Result -> Warmup+createWarmup t = Warmup [t]++-- | The empty Warmup+noWarmup :: Warmup+noWarmup = Warmup [pure Empty]++-- | Create a warmup with no action but just the type of a component+declareWarmup :: Typeable a => a -> Warmup+declareWarmup a = warmupOf a (pure ())++-- | Result of a warmup+data Result =+    Empty+  | Ok [Text]+  | Failed [Text]+  deriving (Eq, Show)++-- | Return True if a Warmup was successful+isSuccess :: Result -> Bool+isSuccess Empty      = True+isSuccess (Ok _)     = True+isSuccess (Failed _) = False++-- | Create a successful Result+ok :: Text -> Result+ok t = Ok [t]++-- | Create a failed Result+failed :: Text -> Result+failed t = Failed [t]++-- | Extract the list of all the messages from a Result+messages :: Result -> [Text]+messages Empty       = []+messages (Ok ms)     = ms+messages (Failed ms) = ms++instance Monoid Result where+  mempty = Empty+  mappend = (<>)++instance Semigroup Result where+  r         <> Empty      = r+  Empty     <> r          = r+  Failed ts <> r          = Failed (ts ++ messages r)+  r         <> Failed ts  = Failed (messages r ++ ts)+  Ok ts1    <> Ok ts2     = Ok (ts1 ++ ts2)+++-- * Run functions++-- | Simple sequential warmup strategy+runWarmup :: Warmup -> IO Result+runWarmup (Warmup as) = foldr' runBoth (pure Empty) as++-- | runBoth runs both tasks and cumulate the results+--   exceptions are being transformed into Failed results+runBoth :: IO Result -> IO Result -> IO Result+runBoth io1 io2 = do+  res1 <- Catch.try io1 :: IO (Either SomeException Result)+  res2 <- Catch.try io2 :: IO (Either SomeException Result)+  pure $+    case (res1, res2) of+      (Right r1, Right r2) -> r1               `mappend` r2+      (Left  r1, Right r2) -> failed (show r1) `mappend` r2+      (Right r1, Left  r2) -> r1               `mappend` failed (show r2)+      (Left  r1, Left  r2) -> Failed [show r1, show r2]

@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.DotSpec where++import           Data.Registry.Dot+import           Data.Registry+import           Protolude+import Data.Text as T+import           Test.Tasty.Extensions++test_dot =+  prop "a dot graph can be generated from a registry" $ do+    let dot = makeDot @(IO Listener) registry+    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\";"+      ,"}"+      ]+++-- * 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)

@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++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++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+    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+    cachedAction++  cached === 1++----+tests = $(testGroupGenerator)

@@ -0,0 +1,51 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}++module Test.Data.Registry.Internal.DynamicSpec where++import           Data.Dynamic+import           Data.Text as T+import           Data.Registry.Internal.Dynamic+import           Data.Registry.Internal.Types+import           Protolude                      as P+import           Test.Tasty.Extensions+import           Type.Reflection                hiding (typeRep)++test_collectInputTypes = test "we can collect the input types of a function" $ do++  collectInputTypes (createFunction (u :: Int)) === []+  collectInputTypes (createFunction (u :: Text -> Int)) === [dynType (u :: Text)]+  collectInputTypes (createFunction (u :: Int -> Text -> Int)) === [dynType (u :: Int), dynType (u :: Text)]+  collectInputTypes (createFunction (u :: Int -> Maybe Double -> Maybe Text)) === [dynType (u :: Int), dynType (u :: Maybe Double)]++test_outputType = test "we can get the output type of a function" $ do++  outputType (dynType (u :: Int)) === dynType (u :: Int)+  outputType (dynType (u :: Text -> Int)) === dynType (u :: Int)+  outputType (dynType (u :: Int -> Text -> Int)) === dynType (u :: Int)+  outputType (dynType (u :: Int -> Maybe Double -> Maybe Text)) === dynType (u :: Maybe Text)++test_applyFunction = test "we can apply a list of dynamic values to a dynamic function" $ do++  (fromDynamic @Int . valueDyn <$> applyFunction (createFunction T.length) [createValue ("hello" :: Text)]) === Right (Just 5)++  let add1 (i::Int) (j::Int) = show (i + j) :: Text+  (fromDynamic @Text . valueDyn <$> applyFunction (createFunction add1) [createValue (1 :: Int), createValue (2 :: Int)]) === Right (Just "3")++  -- no value is returned when an input parameter is incorrect+  (fromDynamic @Int . valueDyn <$> applyFunction (createFunction T.length) [createValue (1 :: Int)]) === Left "failed to apply <<Int>> to : <<Text -> Int>>"++  -- no value is returned when there are not enough inputs+  (fromDynamic @Text . valueDyn <$> applyFunction (createFunction add1) []) === Left "the function Int -> Int -> Text cannot be applied to an empty list of parameters"+++u = undefined++dynType :: forall a . (Typeable a) => a -> SomeTypeRep+dynType = dynTypeRep . toDyn++----+tests = $(testGroupGenerator)

@@ -0,0 +1,92 @@+{-# OPTIONS_GHC -fno-warn-missing-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           Hedgehog+import           Hedgehog.Gen                      as Gen+import           Hedgehog.Range                    as Range+import           Prelude                           (show)+import           Protolude+import           Type.Reflection++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+  +: fun   (genList @(SomeTypeRep, Function))+  +: fun   (genList @(SomeTypeRep, Value))+  +: fun   (genPair @SomeTypeRep @Function)+  +: fun   (genPair @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 genValue = do+  ProvidedValue a _ <- genValue+  pure $ dynTypeRep a++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)++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)++gen :: forall a . (Typeable a) => Gen a+gen = makeUnsafe registry++genText :: Gen Text+genText = Gen.text (Range.linear 2 10) Gen.alphaNum

@@ -0,0 +1,37 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}++module Test.Data.Registry.Internal.MakeSpec where++import           Data.Registry.Internal.Make+import           Data.Registry.Internal.Types+import           Data.Registry.Internal.Stack+import           Data.Text                        as T+import           Protolude                        as P+import           Test.Data.Registry.Internal.Gens+import           Test.Tasty.Extensions+import           Type.Reflection++test_make_inputs_with_cycle = prop "making inputs when there's a cycle must be detected" $ do+  target          <- forall @SomeTypeRep+  context'        <- forall @Context+  functions       <- forall @Functions+  specializations <- forall @Specializations+  modifiers       <- forall @Modifiers+  values          <- forall @Values++  -- put one of the input types to build already in the list of+  -- types being built+  let context = Context (target : _context context')++  let result = runStack (makeInputs [target] context  functions specializations modifiers) values+  case result of+    Left e  -> annotateShow e >> "cycle detected!" `T.isPrefixOf` e === True+    Right _ -> failure+++----+tests = $(testGroupGenerator)

@@ -0,0 +1,82 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}++module Test.Data.Registry.Internal.ReflectionSpec where++import           Data.Dynamic+import           Data.Registry.Internal.Types+import           Data.Registry.Internal.Reflection+import           Prelude                      (String)+import           Protolude                    as P+import           Test.Tasty.Extensions++test_is_function = test "we can check if a type rep represents a function" $ do++  isFunction (dynTypeRep $ toDyn (u :: Int -> Int))    === True+  isFunction (dynTypeRep $ toDyn (u :: Int -> IO Int)) === True+  isFunction (dynTypeRep $ toDyn (u :: Int))           === False+  isFunction (dynTypeRep $ toDyn (u :: IO Int))        === False++test_show_value = test "show value for a simple type" $ do+  valDescriptionToText (describeValue (1 :: Int)    )  === "Int: 1"+  valDescriptionToText (describeValue (1 :: Double) )  === "Double: 1.0"+  valDescriptionToText (describeValue (True :: Bool))  === "Bool: True"+  valDescriptionToText (describeValue ("1" :: Text) )  === "Text: \"1\""+  valDescriptionToText (describeValue ("1" :: String)) === "String: \"1\""++test_show_value_nested_type = test "show value for a nested types" $ do+  valDescriptionToText (describeValue (Just 1 :: Maybe Int)) === "Maybe Int: Just 1"+++  -- putting parentheses around types doesn't really work when type constructors+  -- have more than one argument :-(+  valDescriptionToText (describeValue (Right 1 :: Either Text Int)) === "Either (Text Int): Right 1"+  valDescriptionToText (describeValue ([1] :: [Int])              ) === "[Int]: [1]"++  -- user types must be shown with their full module names+  valDescriptionToText (describeValue mod1) === "Test.Data.Registry.Internal.ReflectionSpec.Mod Int: Mod 1 \"hey\""++test_show_function = test "show simple functions" $ do+  funDescriptionToText (describeFunction add1 ) === "Int -> Int"+  funDescriptionToText (describeFunction add2 ) === "Int -> Int -> Text"+  funDescriptionToText (describeFunction iomod) === "IO (Test.Data.Registry.Internal.ReflectionSpec.Mod Int)"++  funDescriptionToText (describeFunction fun0)  === "IO Int"+  funDescriptionToText (describeFunction fun1)  === "IO Int -> IO Int"+  funDescriptionToText (describeFunction fun2)  === "IO Int -> IO Int -> IO Int"+  funDescriptionToText (describeFunction fun3)  === "IO (Test.Data.Registry.Internal.ReflectionSpec.Mod Int) -> IO Int"++-- * helpers+u = undefined++data Mod a = Mod a Text deriving (Eq, Show)++mod1 :: Mod Int+mod1 = Mod 1 "hey"++iomod :: IO (Mod Int)+iomod = pure (Mod 1 "hey")++add1 :: Int -> Int+add1 i = i + 1++add2 :: Int -> Int -> Text+add2 _ = undefined++fun0 :: IO Int+fun0 = undefined++fun1 :: IO Int -> IO Int+fun1 = undefined++fun2 :: IO Int -> IO Int -> IO Int+fun2 = undefined++fun3 :: IO (Mod Int) -> IO Int+fun3 = undefined++----+tests = $(testGroupGenerator)

@@ -0,0 +1,89 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}++module Test.Data.Registry.Internal.RegistrySpec where++import           Data.Dynamic+import           Data.Registry.Internal.Types+import           Data.Registry.Internal.Stack+import           Data.Registry.Internal.Registry+import           Protolude                        as P hiding (show)+import           Test.Data.Registry.Internal.Gens+import           Test.Tasty.Extensions++test_find_no_value = prop "no value can be found if nothing is stored in the registry" $ do+  value  <- forAll $ gen @Int++  (fromValueDyn <$> findValue (valueDynTypeRep (createValue value)) mempty mempty mempty) === (Nothing :: Maybe (Maybe Int))++test_find_value = prop "find a value in a list of values when there are no specializations" $ do+  (value, values) <- forAll genValues++  (fromValueDyn <$> findValue (valueDynTypeRep (createValue value)) mempty mempty values) === Just (Just value)++test_find_specialized_value = prop "find a value in a list of values when there is a specialization for a given context" $ do+  value <- forAll $ gen @Int+  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)]++  (fromValueDyn <$> findValue (valueDynTypeRep (createValue value)) context specializations values) === Just (Just value)++test_find_no_constructor = prop "no constructor can be found if nothing is stored in the registry" $ do+  value  <- forAll $ gen @Int++  (fromDynamic . funDyn <$> findConstructor (valueDynTypeRep (createValue value)) mempty) === (Nothing :: Maybe (Maybe Int))++test_find_contructor = prop "find a constructor in a list of constructors" $ do+  (TextToInt function) <- forAll $ gen @TextToInt+  functions <- forAll $ (createFunction function `addFunction`) <$> gen @Functions++  let outputType = dynTypeRep (toDyn (1 :: Int))++  (fmap TextToInt <$> (fromDynamic . funDyn <$> findConstructor outputType functions)) ===+    Just (Just (TextToInt function))++test_store_value_no_modifiers = prop "a value can be stored in the list of values" $ do+  (value, values) <- forAll genValues++  let createdValue = createValue value+  let (Right stored) = execStack (storeValue mempty createdValue) values++  let found = findValue (dynTypeRep . toDyn $ value) mempty mempty stored+  (fromValueDyn <$> found) === Just (Just value)++test_store_value_with_modifiers = prop "a value can be stored in the list of values but modified beforehand" $ do+  (value, values) <- forAll genValues++  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 found = findValue valueType mempty mempty stored+  (fromValueDyn <$> found) === Just (Just (value + 1))++test_store_value_ordered_modifiers = prop "modifiers are applied in a LIFO order" $ do+  (value, values) <- forAll genValues++  let valueType = dynTypeRep . toDyn $ value+  let modifiers = Modifiers [+         (valueType, createFunction (\(i:: Int) -> i * 2))+       , (valueType, createFunction (\(i:: Int) -> i + 1))+       ]+  let createdValue = createValue value+  let (Right stored) = execStack (storeValue modifiers createdValue) values++  let found = findValue valueType mempty mempty stored+  (fromValueDyn <$> found) === Just (Just ((value * 2) + 1))++-- *++fromValueDyn = fromDynamic . valueDyn++----+tests = $(testGroupGenerator)

@@ -0,0 +1,235 @@+{-# 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++-- | A regular module can be made without having an explicit Typeable constraint+data LoggingModule = LoggingModule {+  info  :: Text -> IO ()+, debug :: Text -> IO ()+}++loggingModule = make @LoggingModule (fun LoggingModule { 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,84 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# 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.SmallExample where++import           Data.Registry+import           Data.Text             (splitOn)+import           Data.Typeable         (Typeable)+import           Protolude             as P+import           Test.Tasty.Extensions++-- | Components of the application+newtype Logger = Logger {+  info :: Text -> IO ()+} deriving Typeable++newLogger :: Logger+newLogger = Logger print++noLogging = Logger (const (pure ()))++newtype LinesCounter = LinesCounter {+  count :: Text -> Int+} deriving Typeable++newLinesCounter :: LinesCounter+newLinesCounter = LinesCounter $ \t -> length (splitOn "\n" t)++newtype S3 = S3 {+  store :: Text -> IO ()+} deriving Typeable++data S3Config = S3Config {+   bucket :: Text+,  key    :: Text+} deriving (Eq, Show, Typeable)++newS3 :: MonadIO m => S3Config -> Logger -> m S3+newS3 config logger = pure $ S3 $+  \t -> (logger & info) ("storing on S3 with config " <> P.show config) >>+        void (print t) -- send the text to s3++newtype Application = Application {+  run :: Text -> IO Int+} deriving Typeable++newApplication :: MonadIO m => Logger -> LinesCounter -> S3 -> m Application+newApplication logger counter s3 = pure $ Application $ \t -> do+  (logger & info) "count lines"+  let n = (counter & count) t++  (logger & info) "store the lines on s3"+  (s3 & store) ("counted " <> P.show n <> " lines")+  pure n++-- | Create a registry for all constructors+registry =+     funAs @IO (newS3 @IO)+  +: funAs @IO (newApplication @IO)+  +: funTo     @IO newLogger+  +: funTo     @IO newLinesCounter+  +: valTo     @IO (S3Config "bucket" "key")+  +: end++-- | To create the application you call `make` for the `Application` type+--   with the registry above+--   Since the registry contains all functions and values necessary to create the application+--   Everything will work fine+createApplication :: IO Application+createApplication = make @(IO Application) (funTo @IO noLogging +: registry)++test_create = test "create the application" $ do+  app <- liftIO $ createApplication -- nothing should crash!+  r   <- liftIO $ (app & run) "hello\nworld"+  r === 2++----+tests = $(testGroupGenerator)

@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.WarmupSpec where++import           Control.Monad.Catch+import           Prelude                (show)+import           Protolude+import           Test.Tasty.Extensions+import           Data.Registry.Warmup++test_runBoth1 =+  prop "all results are collected when running 2 start/stop tasks" $ do+    r1 <- forAll genResult+    r2 <- forAll genResult+    r  <- liftIO $ pure r1 `runBoth` pure r2+    messages r === messages r1 ++ messages r2++test_runBoth2 =+  prop "exception messages are also collected" $ do+    r  <- liftIO $ throwM (Error "boom1") `runBoth` throwM (Error "boom2")+    messages r === ["boom1", "boom2"]++-- * helpers+newtype Error = Error Text++instance Show Error where+  show (Error t) = toS t++instance Exception Error++genResult :: Gen Result+genResult =+  choice [genEmpty, genFailed, genOk]++genEmpty  = pure Empty+genFailed = failed <$> element simpsons+genOk     = ok     <$> element colours++----+tests = $(testGroupGenerator)

@@ -0,0 +1,55 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-|++Registry      : Test.Tasty.Extensions+Description : Tasty / Hedgehog / HUnit integration++This module unifies property based testing with Hedgehog+and one-off tests.++-}+module Test.Tasty.Extensions (+  module Hedgehog+, module Tasty+, gotException+, prop+, test+, minTestsOk+) where++import           GHC.Stack+import           Hedgehog            as Hedgehog hiding (test)+import           Hedgehog.Corpus     as Hedgehog+import           Hedgehog.Gen        as Hedgehog hiding (discard, print)+import           Protolude           hiding ((.&.))+import           Test.Tasty          as Tasty+import           Test.Tasty.Hedgehog as Tasty+import           Test.Tasty.TH       as Tasty++-- | Create a Tasty test from a Hedgehog property+prop :: HasCallStack => TestName -> PropertyT IO () -> [TestTree]+prop name p = [withFrozenCallStack $ testProperty name (Hedgehog.property p)]++-- | Create a Tasty test from a Hedgehog property called only once+test :: HasCallStack => TestName -> PropertyT IO () -> [TestTree]+test name p = withFrozenCallStack $+  minTestsOk 1  . localOption (HedgehogShrinkLimit (Just (0 :: ShrinkLimit))) <$> prop name p++gotException :: forall a . (HasCallStack, Show a) => a -> PropertyT IO ()+gotException a = withFrozenCallStack $ do+  res <- liftIO (try (evaluate a) :: IO (Either SomeException a))+  case res of+    Left _  -> assert True+    Right _ -> annotateShow ("excepted an exception" :: Text) >> assert False++++-- * Parameters++minTestsOk :: Int -> (TestTree -> TestTree)+minTestsOk n = localOption (HedgehogTestLimit (Just (fromInteger (toInteger n))))

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}