registry 0.2.1.0 → 0.3.0.0
raw patch · 56 files changed
+1762/−1932 lines, 56 filessetup-changed
Files
- LICENSE.txt +6/−7
- README.md +44/−0
- Setup.hs +1/−1
- registry.cabal +4/−5
- src/Data/Registry.hs +16/−18
- src/Data/Registry/Dot.hs +17/−17
- src/Data/Registry/Internal/Cache.hs +19/−21
- src/Data/Registry/Internal/Dot.hs +39/−33
- src/Data/Registry/Internal/Dynamic.hs +51/−40
- src/Data/Registry/Internal/Make.hs +67/−62
- src/Data/Registry/Internal/Reflection.hs +35/−38
- src/Data/Registry/Internal/Registry.hs +38/−47
- src/Data/Registry/Internal/Stack.hs +12/−14
- src/Data/Registry/Internal/Statistics.hs +17/−16
- src/Data/Registry/Internal/Types.hs +85/−83
- src/Data/Registry/Lift.hs +26/−28
- src/Data/Registry/Make.hs +76/−71
- src/Data/Registry/RIO.hs +21/−175
- src/Data/Registry/Registry.hs +201/−160
- src/Data/Registry/Solver.hs +30/−29
- src/Data/Registry/State.hs +10/−12
- src/Data/Registry/Statistics.hs +29/−31
- src/Data/Registry/TH.hs +38/−36
- src/Data/Registry/Warmup.hs +0/−114
- test/Test/Data/Registry/DotSpec.hs +28/−27
- test/Test/Data/Registry/GenSpec.hs +57/−55
- test/Test/Data/Registry/Internal/CacheSpec.hs +5/−5
- test/Test/Data/Registry/Internal/DynamicSpec.hs +11/−15
- test/Test/Data/Registry/Internal/Gens.hs +7/−8
- test/Test/Data/Registry/Internal/GensRegistry.hs +62/−58
- test/Test/Data/Registry/Internal/MakeSpec.hs +17/−17
- test/Test/Data/Registry/Internal/ReflectionSpec.hs +22/−23
- test/Test/Data/Registry/Internal/RegistrySpec.hs +20/−19
- test/Test/Data/Registry/Internal/TypesSpec.hs +16/−6
- test/Test/Data/Registry/Make/MakeSpec.hs +38/−20
- test/Test/Data/Registry/Make/MemoizeSpec.hs +48/−39
- test/Test/Data/Registry/Make/SpecializationSpec.hs +132/−104
- test/Test/Data/Registry/Make/TweakingSpec.hs +29/−21
- test/Test/Data/Registry/MonadRandomSpec.hs +48/−39
- test/Test/Data/Registry/RIOSpec.hs +0/−34
- test/Test/Data/Registry/RegistrySpec.hs +20/−21
- test/Test/Data/Registry/SimpleExamples.hs +34/−29
- test/Test/Data/Registry/SmallExample.hs +37/−30
- test/Test/Data/Registry/THSpec.hs +30/−28
- test/Test/Data/Registry/WarmupSpec.hs +0/−73
- test/Test/Tasty/Extensions.hs +59/−52
- test/Test/Tutorial/Application.hs +71/−66
- test/Test/Tutorial/Exercise1.hs +11/−11
- test/Test/Tutorial/Exercise2.hs +9/−9
- test/Test/Tutorial/Exercise3.hs +9/−8
- test/Test/Tutorial/Exercise4.hs +12/−9
- test/Test/Tutorial/Exercise5.hs +20/−20
- test/Test/Tutorial/Exercise6.hs +13/−13
- test/Test/Tutorial/Exercise7.hs +7/−7
- test/Test/Tutorial/Exercise8.hs +5/−5
- test/test.hs +3/−3
LICENSE.txt view
@@ -1,17 +1,16 @@-Copyright (c) 2018 Eric Torreborre <etorreborre@yahoo.com>+Copyright (c) 2018-2022 Eric Torreborre <etorreborre@yahoo.com> -Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated +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, +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 +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 +CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.-
+ README.md view
@@ -0,0 +1,44 @@+# Registry [](https://hackage.haskell.org/package/registry) [](https://github.com/etorreborre/registry/actions)+++[](https://gitter.im/etorreborre/registry?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)++##### *It's functions all the way down* <img src="doc/images/unboxed-bottomup.jpg" border="0"/>++#### Presentation++This library provides a data structure, a `Registry`, to control the creation of functions from other functions. You can use this technique to:++ - create applications out of software components ("dependency injection")+ - fine tune encoders/decoders (see the [`registry-aeson](http://github.com/etorreborre/registry-aeson) and the [`registry-messagepack](http://github.com/etorreborre/registry-messagepack) projects)+ - create composable data generators for nested datatypes (see the [`registry-hedgehog](http://github.com/etorreborre/registry-hedgehog) and the [`registry-hedgehog-aeson](http://github.com/etorreborre/registry-hedgehog-aeson) projects)++You can watch a video presenting the main ideas behind the library [here](https://skillsmatter.com/skillscasts/12299-wire-once-rewire-twice).++The following sections introduce in more details the problem that this library is addressing, the concepts behind the solution and various use-cases which can arise on real projects:++ 1. [what is the problem?](doc/motivation.md)+ 1. the concept of a [Registry](doc/registry.md) and the resolution algorithm+ 1. how does this [compare to monad transformers and effects](https://github.com/etorreborre/effects)?++#### Tutorials++ 1. tutorial: use a `Registry` to create [applications](doc/tutorial.md) and define components+ 1. use a `Registry` to compose [Hedgehog generators](https://github.com/etorreborre/registry-hedgehog/doc/generators.md)++#### How-tos++ 1. how to [install this library](doc/install.md)?+ 1. how to do [mocking](doc/applications.md#integration)?+ 1. how to [specialize some values in some contexts](doc/applications.md#context-dependent-configurations)?+ 1. how to [control effects](doc/applications.md#memoization) occurring when creating a component (like a connection pool)?+ 1. how to [allocate resources](doc/applications.md#resources) which must be finalized?+ 1. how to [extract a dot graph from the registry](doc/dot.md) in an application?+ 1. how to [interact with a library using monad transformers](https://github.com/etorreborre/registry/blob/master/test/Test/Data/Registry/MonadRandomSpec.hs)?+ 1. how to [remove boilerplate](doc/boilerplate.md) due to parameter passing?+ 1. how to [create a typeclass from a record of functions](doc/typeclass.md)?++#### Reference guides++ 1. [main operators and functions](doc/reference.md)+ 1. [implementation notes](doc/implementation.md)
Setup.hs view
@@ -1,4 +1,4 @@-import Distribution.Simple+import Distribution.Simple main :: IO () main = defaultMain
registry.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: be001d682bb474fc6c2d6ad9d6b75250646d06b379b0e6e1296a8a6259ac1e51+-- hash: 11944d94a4212f7ef5df1e555aa3394d396814763cc31d4a42bec472afccddfc name: registry-version: 0.2.1.0+version: 0.3.0.0 synopsis: data structure for assembling components description: This library provides a "Registry" which is a data structure containing a list of functions and values representing dependencies in a directed acyclic graph. A `make` function can then be used to create a value of a specific type out of the registry. You can start with the [README](https://github.com/etorreborre/registry/blob/master/README.md) for a full description of the library.@@ -16,6 +16,8 @@ license: MIT license-file: LICENSE.txt build-type: Simple+extra-source-files:+ README.md source-repository head type: git@@ -42,7 +44,6 @@ Data.Registry.State Data.Registry.Statistics Data.Registry.TH- Data.Registry.Warmup other-modules: Paths_registry hs-source-dirs:@@ -114,11 +115,9 @@ 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.THSpec- Test.Data.Registry.WarmupSpec Test.Tasty.Extensions Test.Tutorial.Application Test.Tutorial.Exercise1
src/Data/Registry.hs view
@@ -1,19 +1,17 @@-{- |-- Import this module if you want to access all the functionalities of the- Registry API---}-module Data.Registry (- module M-) where+-- |+--+-- Import this module if you want to access all the functionalities of the+-- Registry API+module Data.Registry+ ( module M,+ )+where -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.State as M -- Stateful modifications of a registry-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.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.RIO as M -- ResourceT monad for effectful instantiation+import Data.Registry.Registry as M -- The Registry data structure+import Data.Registry.Solver as M -- Type-level constraints to check if we can make a component from a registry+import Data.Registry.State as M -- Stateful modifications of a registry+import Data.Registry.Statistics as M -- Provide statistics about the execution of a registry
src/Data/Registry/Dot.hs view
@@ -1,29 +1,29 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MonoLocalBinds #-} -{- |- This module 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 D-, makeDot-, makeDotEither-) where+-- |+-- This module 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 D,+ makeDot,+ makeDotEither,+ )+where -import Data.Registry.Internal.Dot as D-import Data.Registry.Statistics-import Data.Registry.Registry-import Protolude+import Data.Registry.Internal.Dot as D+import Data.Registry.Registry+import Data.Registry.Statistics+import Protolude -- | 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) => Registry ins out -> Dot+makeDot :: forall a ins out. (Typeable a) => Registry ins out -> Dot makeDot = toDot . operations . makeStatistics @a -- | Similar to `make` but does not check if `a` can be made out of the 'Registry' -- 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 :: forall a ins out. (Typeable a) => Registry ins out -> Either Text Dot makeDotEither r = toDot . operations <$> makeStatisticsEither @a r
src/Data/Registry/Internal/Cache.hs view
@@ -1,16 +1,14 @@-{- |-- 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---}+-- |+--+-- 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 module Data.Registry.Internal.Cache where -import Data.Map.Strict-import Data.Registry.Internal.Types (SpecializationPath)-import Protolude as P+import Data.Map.Strict+import Data.Registry.Internal.Types (SpecializationPath)+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.@@ -24,17 +22,17 @@ -- | 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, Typeable a) => Cache a -> Key -> m a -> m a+fetch :: forall a m. (MonadIO m, Typeable a) => Cache a -> Key -> m a -> m a fetch (Cache var) key action =- do m <- liftIO $ P.readMVar var- case lookup key m of- Just a ->- pure a-- Nothing -> do- val <- action- liftIO $ modifyMVar_ var (\cached -> pure $ insert key val cached)- pure val+ do+ m <- liftIO $ P.readMVar var+ case lookup key m of+ Just a ->+ pure a+ Nothing -> do+ val <- action+ liftIO $ modifyMVar_ var (\cached -> pure $ insert key val cached)+ pure val -- | Create an empty cache. newCache :: IO (Cache a)
src/Data/Registry/Internal/Dot.hs view
@@ -1,42 +1,49 @@-{- |- Nested datatype to track the resolution algorithm-- From this data type we can draw a graph of the full- instantation of a value--}+-- |+-- 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+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 [] = [] makeEdges (AppliedFunction out ins : rest) = ((out,) <$> ins) <> makeEdges rest -- * DOT GRAPH -- | A DOT graph-newtype Dot = Dot {- unDot :: Text-} deriving (Eq, Show)+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@@ -45,13 +52,13 @@ 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)- <> ["}"]+ in Dot $+ T.unlines $+ [ "strict digraph {",+ " node [shape=record]"+ ]+ <> (toDotEdge valueTypes <$> edges)+ <> ["}"] -- | Update a map classifying values by type countValueTypes :: Value -> DotState ()@@ -63,7 +70,6 @@ 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@@ -80,7 +86,7 @@ toDotEdge valuesByType (value1, value2) = let v1 = toDotVertex valuesByType value1 v2 = toDotVertex valuesByType value2- in v1 <> " -> " <> v2 <> ";"+ in v1 <> " -> " <> v2 <> ";" -- | Represent a value as a vertex in a dot graph -- we use some state to keep track of values of the@@ -98,14 +104,14 @@ Just hashes -> case hashes of [_] -> Nothing- _ -> (+1) <$> elemIndex valueHash hashes-- in adjust (nodeDescription (valDescription value) valueCounter)+ _ -> (+ 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)+hashOf value =+ hash+ (unDependencies . valDependencies $ value, valDescription value) -- | Description of a Value in the DOT graph nodeDescription :: ValueDescription -> ValueCounter -> Text@@ -116,7 +122,7 @@ -- | Don't show the counter if there showValueCounter :: ValueCounter -> Text-showValueCounter Nothing = ""+showValueCounter Nothing = "" showValueCounter (Just n) = "-" <> show n -- | We need to process the node descriptions
src/Data/Registry/Internal/Dynamic.hs view
@@ -1,57 +1,68 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{- |- Utility functions to work with 'Dynamic' values--}+-- |+-- 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 as P-import Type.Reflection+import Data.Dynamic+import Data.Registry.Internal.Types+import Data.Text+import Protolude as P+import Type.Reflection -- | Apply a function to a list of 'Dynamic' values applyFunction ::- Function -- ^ function- -> [Value] -- ^ inputs- -> Either Text Value -- ^ result+ -- | function+ Function ->+ -- | inputs+ [Value] ->+ -- | result+ Either Text Value applyFunction function [] =- if P.null (collectInputTypes function) then- pure $ makeCreatedValue (funDyn function) (ValueDescription (_outputType . funDescription $ function) Nothing) mempty- else- Left $ "the function "- <> show (dynTypeRep (funDyn function))- <> " cannot be applied to an empty list of parameters"-+ if P.null (collectInputTypes function)+ then pure $ makeCreatedValue (funDyn function) (ValueDescription (_outputType . funDescription $ function) Nothing) mempty+ else+ Left $+ "the function "+ <> show (dynTypeRep (funDyn function))+ <> " cannot be applied to an empty list of parameters" applyFunction function values =- do created <- applyFunctionDyn (funDyn function) (valueDyn <$> values)- let description = ValueDescription (_outputType . funDescription $ function) Nothing- let dependencies = foldMap dependenciesOn values+ do+ created <- applyFunctionDyn (funDyn function) (valueDyn <$> values)+ let description = ValueDescription (_outputType . funDescription $ function) Nothing+ let dependencies = foldMap dependenciesOn values - pure $ makeCreatedValue created description dependencies+ pure $ makeCreatedValue created description dependencies -- | Apply a function modifying a single value and keeping its type -- to be used with Modifiers applyModification ::- Function -- ^ function- -> Value -- ^ inputs- -> Either Text Value -- ^ result+ -- | function+ Function ->+ -- | inputs+ Value ->+ -- | result+ Either Text Value applyModification function value =- do created <- applyFunctionDyn (funDyn function) [valueDyn value]- let description = ValueDescription (_outputType . funDescription $ function) Nothing- pure $ CreatedValue created description (specializationContext value) (usedSpecialization value) (valDependencies value)+ do+ created <- applyFunctionDyn (funDyn function) [valueDyn value]+ let description = ValueDescription (_outputType . funDescription $ function) Nothing+ pure $ CreatedValue created description (specializationContext value) (usedSpecialization value) (valDependencies value) -- | Apply a Dynamic function to a list of Dynamic values applyFunctionDyn ::- Dynamic -- ^ function- -> [Dynamic] -- ^ inputs- -> Either Text Dynamic -- ^ result+ -- | function+ Dynamic ->+ -- | inputs+ [Dynamic] ->+ -- | result+ Either Text Dynamic applyFunctionDyn f [] =- Left $ "the function "- <> show (dynTypeRep f)- <> " cannot be applied to an empty list of parameters"-applyFunctionDyn f [i ] = applyOneParam f i+ 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@@ -64,12 +75,12 @@ -- | 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 _ = []+ 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+outputType r = r
src/Data/Registry/Internal/Make.hs view
@@ -1,27 +1,26 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -{- |- Untyped implementation of the functionalities in- 'Data.Registry.Make'--}+-- |+-- Untyped implementation of the functionalities in+-- 'Data.Registry.Make' module Data.Registry.Internal.Make where -import qualified Data.List as L hiding (unlines)-import Data.Registry.Internal.Dynamic-import Data.Registry.Internal.Reflection (showSingleType)-import Data.Registry.Internal.Registry-import Data.Registry.Internal.Stack-import Data.Registry.Internal.Types-import qualified Data.Text as T-import Protolude as P hiding (Constructor)-import Type.Reflection+import qualified Data.List as L hiding (unlines)+import Data.Registry.Internal.Dynamic+import Data.Registry.Internal.Reflection (showSingleType)+import Data.Registry.Internal.Registry+import Data.Registry.Internal.Stack+import Data.Registry.Internal.Types+import qualified Data.Text as T+import Protolude as P hiding (Constructor)+import Type.Reflection -- * WARNING: HIGHLY UNTYPED IMPLEMENTATION ! @@ -32,12 +31,12 @@ -- Specializations is a list of specific values to use in a given context, overriding the normal search -- Modifiers is a list of functions to apply right before a value is stored in the Registry makeUntyped ::- SomeTypeRep- -> Context- -> Functions- -> Specializations- -> Modifiers- -> Stack (Maybe Value)+ 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?@@ -47,27 +46,29 @@ Nothing -> -- if not, is there a way to build such value? case findConstructor targetType functions of- Nothing -> lift $ Left $- "When trying to create the following values\n\n "- <> T.intercalate "\nrequiring " (showContextTargets context)- <> "\n\nNo constructor was found for " <> showSingleType targetType-+ Nothing ->+ lift $+ Left $+ "When trying to create the following values\n\n "+ <> T.intercalate "\nrequiring " (showContextTargets context)+ <> "\n\nNo constructor was found for "+ <> showSingleType targetType Just function -> do let inputTypes = collectInputTypes function inputs <- makeInputs function inputTypes context functions specializations modifiers if length inputs /= length inputTypes- then- -- report an error if we cannot make enough input parameters to apply the function+ then -- report an error if we cannot make enough input parameters to apply the function+ let madeInputTypes = fmap valueDynTypeRep inputs missingInputTypes = inputTypes L.\\ madeInputTypes- in- lift $ Left $- T.unlines- $ ["could not make all the inputs for ", show (funDescription function), ". Only "]- <> (show <$> inputs)- <> ["could be made. Missing"]- <> fmap show missingInputTypes+ in lift $+ Left $+ T.unlines $+ ["could not make all the inputs for ", show (funDescription function), ". Only "]+ <> (show <$> inputs)+ <> ["could be made. Missing"]+ <> fmap show missingInputTypes else do -- else apply the function and store the output value in the registry value <- lift $ applyFunction function inputs@@ -75,8 +76,6 @@ functionApplied modified inputs pure (Just modified)-- Just v -> do modified <- storeValue modifiers v pure (Just modified)@@ -85,35 +84,42 @@ -- for every target type in the context showContextTargets :: Context -> [Text] showContextTargets (Context context) =- fmap (\(t, f) ->- case f of- Nothing -> show t- Just function -> show t <> "\t\t\t(required for the constructor " <> show function <> ")")- (reverse context)+ fmap+ ( \(t, f) ->+ case f of+ Nothing -> show t+ Just function -> show t <> "\t\t\t(required for the constructor " <> show function <> ")"+ )+ (reverse context) -- | 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 ::- Function- -> [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+ Function ->+ -- | input types to build+ [SomeTypeRep] ->+ -- | current context of types being built+ Context ->+ -- | available functions to build values+ Functions ->+ -- | list of values to use when in a specific context+ Specializations ->+ -- | modifiers to apply before storing made values+ Modifiers ->+ Stack [Value] -- list of made values makeInputs _ [] _ _ _ _ = pure []- makeInputs function (i : ins) c@(Context context) functions specializations modifiers = if i `elem` contextTypes c then- lift $ Left- $ toS- $ T.unlines- $ ["cycle detected! The current types being built are "]- <> (show <$> context)- <> ["But we are trying to build again " <> show i]+ lift $+ Left $+ toS $+ T.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, Just (funDynTypeRep function)) : context)) functions specializations modifiers case madeInput of@@ -121,6 +127,5 @@ -- if one input cannot be made, iterate with the rest for better reporting -- of what could be eventually made makeInputs function ins (Context context) functions specializations modifiers- Just v -> (v :) <$> makeInputs function ins (Context context) functions specializations modifiers
src/Data/Registry/Internal/Reflection.hs view
@@ -1,29 +1,29 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeInType #-} -{- |- Utility functions to display or manipulate types--}+-- |+-- Utility functions to display or manipulate types module Data.Registry.Internal.Reflection where -import Data.Semigroup-import Data.Text as T-import Data.Typeable (splitTyConApp)+import Data.Semigroup+import Data.Text as T+import Data.Typeable (splitTyConApp) #if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0) import Protolude as P hiding (intercalate, TypeRep, isPrefixOf, (<>), typeOf) #else import Protolude as P hiding (intercalate, TypeRep, isPrefixOf, (<>)) #endif-import Type.Reflection as Reflection-import GHC.Exts +import GHC.Exts+import Type.Reflection as Reflection+ -- | Return true if the type of this type rep represents a function isFunction :: SomeTypeRep -> Bool isFunction d = case d of SomeTypeRep (Fun _ _) -> True- _other -> False+ _other -> False -- | Show the full type of a typeable value showFullValueType :: Typeable a => a -> Text@@ -36,39 +36,33 @@ -- | 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 :: forall (r1 :: RuntimeRep) (arg :: TYPE r1). (TypeRep arg -> Text) showTheFullValueType a = case a of Fun (App t1 t2) t3 -> showNested (SomeTypeRep t1) (SomeTypeRep t2) <> " -> " <> showTheFullValueType t3- Fun t1 t2 -> showTheFullValueType t1 <> " -> " <> showTheFullValueType t2- App t1 t2 -> showNested (SomeTypeRep t1) (SomeTypeRep t2)- _other -> 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 :: forall (r1 :: RuntimeRep) (arg :: TYPE r1). (TypeRep arg -> ([Text], Text)) showTheFullFunctionType a = case a of Fun (App t1 t2) t3 -> let (ins, out) = showTheFullFunctionType t3- in (showNested (SomeTypeRep t1) (SomeTypeRep t2) : ins, out)-+ in (showNested (SomeTypeRep t1) (SomeTypeRep t2) : ins, out) Fun t1 t2 -> let in1 = showTheFullValueType t1 (ins, out) = showTheFullFunctionType t2- in (in1 : ins, out)-+ in (in1 : ins, out) App t1 t2 -> ([], showNested (SomeTypeRep t1) (SomeTypeRep t2))- _other -> ([], showSingleType (SomeTypeRep a)) @@ -81,32 +75,35 @@ showSingleType :: SomeTypeRep -> Text showSingleType a = case splitTyConApp a of- (con, []) -> showType con+ (con, []) -> showType con (con, [arg]) -> showType con <> " " <> showSingleType arg- (con, args) -> showType con <> " " <> show (fmap showSingleType args)-- where showType x =- let typeWithModuleName = showWithModuleName x- in if mustShowModuleName typeWithModuleName then typeWithModuleName else show x+ (con, args) -> showType con <> " " <> show (fmap showSingleType args)+ where+ showType x =+ let typeWithModuleName = showWithModuleName x+ in if mustShowModuleName typeWithModuleName then typeWithModuleName else show x -- | 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 other Base types- , "GHC.Maybe." -- for Maybe- , "Data.Either." -- for Either- , "Data.Text.Internal"]+mustShowModuleName name =+ not $+ P.any identity $+ fmap+ (`isPrefixOf` name)+ [ "GHC.Types.", -- for Int, Double,..+ "GHC.Base.", -- for other Base types+ "GHC.Maybe.", -- 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+ 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)"@
src/Data/Registry/Internal/Registry.hs view
@@ -1,19 +1,18 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE UndecidableInstances #-} -{- |- Internal structure of a 'Registry' and- associated functions--}+-- |+-- Internal structure of a 'Registry' and+-- associated functions module Data.Registry.Internal.Registry where -import Data.Registry.Internal.Dynamic-import Data.Registry.Internal.Stack-import Data.Registry.Internal.Types-import Protolude as P-import Type.Reflection+import Data.Registry.Internal.Dynamic+import Data.Registry.Internal.Stack+import Data.Registry.Internal.Types+import Protolude as P+import Type.Reflection -- | Find a value having a target type from: -- - a list of "preferred values" (Specializations) to select when we are trying@@ -34,13 +33,12 @@ -- 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+ SomeTypeRep ->+ Context ->+ Specializations ->+ Values ->+ Maybe Value 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@@ -48,8 +46,7 @@ bestSpecializedValue = findBestSpecializedValue target context applicableSpecializations compatibleValue = findCompatibleCreatedValue target specializations values-- in bestSpecializedValue <|> compatibleValue+ in bestSpecializedValue <|> compatibleValue -- | Among all the applicable specializations take the most specific one -- if there exists any@@ -60,8 +57,7 @@ -- 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+ in createValueFromSpecialization context <$> bestSpecializedValue -- | Among all the created values, take a compatible one --@@ -71,34 +67,30 @@ findCompatibleCreatedValue target specializations (Values vs) = let isApplicableValue value = valueDynTypeRep value == target isNotSpecializedForAnotherContext value =- not (hasSpecializedDependencies specializations value) &&- not (isInSpecializationContext target value)+ not (hasSpecializedDependencies specializations value)+ && not (isInSpecializationContext target value) applicableValues = filter ((&&) <$> isApplicableValue <*> isNotSpecializedForAnotherContext) vs-- in head applicableValues+ in head applicableValues -- | Find a constructor function returning a target type -- from a list of constructors findConstructor ::- SomeTypeRep- -> Functions- -> Maybe Function-findConstructor _ (Functions [] ) = Nothing+ 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)-+ if outputType (SomeTypeRep out) == target+ then Just f+ else findConstructor target (Functions rest) -- a "function" with no arguments SomeTypeRep out ->- if outputType (SomeTypeRep out) == target then- Just f- else- findConstructor target (Functions rest)+ if outputType (SomeTypeRep out) == target+ then Just f+ else findConstructor target (Functions rest) -- | Given a newly built value, check if there are modifiers for that -- value and apply them before "storing" the value which means@@ -107,17 +99,16 @@ -- 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+ Modifiers ->+ Value ->+ Stack Value storeValue (Modifiers ms) value = let modifiers = findModifiers ms-- in do valueToStore <- modifyValue value modifiers- modifyValues (addValue valueToStore)- pure valueToStore+ in do+ valueToStore <- modifyValue value modifiers+ modifyValues (addValue valueToStore)+ pure valueToStore where -- find the applicable modifiers findModifiers = filter (\(m, _) -> valueDynTypeRep value == m)
src/Data/Registry/Internal/Stack.hs view
@@ -1,16 +1,14 @@-{- |- 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---}+-- |+-- 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.Statistics-import Data.Registry.Internal.Types-import Protolude+import Data.Registry.Internal.Statistics+import Data.Registry.Internal.Types+import Protolude -- | Monadic stack for the resolution algorithm type Stack a = StateT Statistics (Either Text) a@@ -48,14 +46,14 @@ -- | Modify the current list of values modifyValues :: (Values -> Values) -> Stack ()-modifyValues f = modifyStatistics (\s -> s { values = f (values s) })+modifyValues f = modifyStatistics (\s -> s {values = f (values s)}) modifyOperations :: (Operations -> Operations) -> Stack ()-modifyOperations f = modifyStatistics (\s -> s { operations = f (operations s) })+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 ()-functionApplied output inputs = modifyOperations (AppliedFunction output inputs:)+functionApplied output inputs = modifyOperations (AppliedFunction output inputs :)
src/Data/Registry/Internal/Statistics.hs view
@@ -7,9 +7,9 @@ -} module Data.Registry.Internal.Statistics where -import Data.Registry.Internal.Types-import Protolude-import Type.Reflection+import Data.Registry.Internal.Types+import Protolude+import Type.Reflection -- * DATA TYPES @@ -17,10 +17,11 @@ -- - the created values -- - the applied functions -- - the specializations used to create values-data Statistics = Statistics {- operations :: Operations-, values :: Values-} deriving (Show)+data Statistics = Statistics+ { operations :: Operations,+ values :: Values+ }+ deriving (Show) instance Semigroup Statistics where Statistics ops1 vs1 <> Statistics ops2 vs2 =@@ -38,13 +39,14 @@ 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)+data AppliedFunction = AppliedFunction+ { _outputValue :: Value,+ _inputValues :: [Value]+ }+ deriving (Show) initStatistics :: Values -> Statistics-initStatistics vs = mempty { values = vs }+initStatistics vs = mempty {values = vs} -- | Return the specializations used during the creation of values usedSpecializations :: Statistics -> [Specialization]@@ -53,8 +55,8 @@ Values [] -> [] Values (v : vs) -> case usedSpecialization v of- Just s -> s : usedSpecializations stats { values = Values vs }- Nothing -> usedSpecializations stats { values = Values vs }+ 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.@@ -70,9 +72,8 @@ valuePaths v@(CreatedValue _ _ _ _ (Dependencies ds)) = do d <- ds (v :) <$> valuePaths d- valuePaths _ = [] -- | Find the most recently created value of a given type-findMostRecentValue :: forall a . (Typeable a) => Statistics -> Maybe Value+findMostRecentValue :: forall a. (Typeable a) => Statistics -> Maybe Value findMostRecentValue stats = find (\v -> valueDynTypeRep v == someTypeRep (Proxy :: Proxy a)) $ unValues (values stats)
src/Data/Registry/Internal/Types.hs view
@@ -1,21 +1,20 @@ {-# 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 hiding (last)-import Prelude (show)-import Protolude as P hiding (show)-import qualified Protolude as P-import Type.Reflection+-- |+-- 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 qualified Data.Text as T hiding (last)+import Protolude as P hiding (show)+import qualified Protolude as P+import Type.Reflection+import Prelude (show) -- | 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@@ -25,8 +24,8 @@ -- 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 (Maybe Context) (Maybe Specialization) Dependencies+data Value+ = CreatedValue Dynamic ValueDescription (Maybe Context) (Maybe Specialization) Dependencies | ProvidedValue Dynamic ValueDescription deriving (Show) @@ -37,10 +36,11 @@ -- | 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)+data ValueDescription = ValueDescription+ { _valueType :: Text,+ _valueValue :: Maybe Text+ }+ deriving (Eq, Show) instance Hashable ValueDescription where hash (ValueDescription d v) = hash (d, v)@@ -84,42 +84,42 @@ -- | 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+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 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+specializationContext _ = Nothing -- | Return the specialization used to create a specific values usedSpecialization :: Value -> Maybe Specialization usedSpecialization (CreatedValue _ _ _ specialization _) = specialization-usedSpecialization _ = Nothing+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 -> target `elem` (contextTypes context)- Nothing -> False+ Nothing -> False -- | Return True if a value has transitives dependencies which are -- specialized values@@ -127,8 +127,7 @@ hasSpecializedDependencies (Specializations ss) v = let DependenciesTypes ds = dependenciesTypes $ valDependencies v targetTypes = specializationTargetType <$> ss-- in not . P.null $ targetTypes `intersect` ds+ 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)@@ -137,13 +136,14 @@ createFunction :: (Typeable f) => f -> Function createFunction f = let dynType = toDyn f- in Function dynType (describeFunction f)+ in Function dynType (describeFunction f) -- | Description of a 'Function' with input types and output type-data FunctionDescription = FunctionDescription {- _inputTypes :: [Text]- , _outputType :: Text- } deriving (Eq, Show)+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'@@ -177,8 +177,8 @@ -- | A Typed value or function 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+data Typed a+ = TypedValue Value | TypedFunction Function -- | This is a list of functions (or "constructors") available for constructing values@@ -187,10 +187,9 @@ -- | Display a list of constructors describeFunctions :: Functions -> Text describeFunctions (Functions fs) =- if P.null fs then- ""- else- unlines (funDescriptionToText . funDescription <$> fs)+ if P.null fs+ then ""+ else unlines (funDescriptionToText . funDescription <$> fs) -- | Add one more Function to the list of Functions addFunction :: Function -> Functions -> Functions@@ -198,15 +197,14 @@ -- | List of values available which can be used as parameters to -- constructors for building other values-newtype Values = Values { unValues :: [Value] } deriving (Show, Semigroup, Monoid)+newtype Values = Values {unValues :: [Value]} deriving (Show, Semigroup, Monoid) -- | Display a list of values describeValues :: Values -> Text describeValues (Values vs) =- if P.null vs then- ""- else- unlines (valDescriptionToText . valDescription <$> vs)+ if P.null vs+ then ""+ else unlines (valDescriptionToText . valDescription <$> vs) -- | Add one more Value to the list of Values addValue :: Value -> Values -> Values@@ -218,9 +216,10 @@ -- better error messages -- IMPORTANT: this is a *stack*, the deepest elements in the value -- graph are first in the list-data Context = Context {- _contextStack :: [(SomeTypeRep, Maybe SomeTypeRep)]-} deriving (Eq, Show)+data Context = Context+ { _contextStack :: [(SomeTypeRep, Maybe SomeTypeRep)]+ }+ deriving (Eq, Show) instance Semigroup Context where Context c1 <> Context c2 = Context (c1 <> c2)@@ -234,28 +233,32 @@ contextTypes (Context cs) = fmap fst cs -- | The values that a value depends on-newtype Dependencies = Dependencies {- unDependencies :: [Value]-} deriving (Show, Semigroup, Monoid)+newtype Dependencies = Dependencies+ { unDependencies :: [Value]+ }+ deriving (Show, Semigroup, Monoid) -- | The values types that a value depends on-newtype DependenciesTypes = DependenciesTypes {- unDependenciesTypes :: [SomeTypeRep]-} deriving (Eq, Show, Semigroup, Monoid)+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)+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 {- unSpecializations :: [Specialization]-} 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@@ -269,10 +272,11 @@ -- 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 :: SpecializationPath-, _specializationValue :: Value-} deriving (Show)+data Specialization = Specialization+ { _specializationPath :: SpecializationPath,+ _specializationValue :: Value+ }+ deriving (Show) type SpecializationPath = NonEmpty SomeTypeRep @@ -297,7 +301,7 @@ -- | 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 (Specialization specializationPath _) =+isContextApplicable context (Specialization specializationPath _) = P.all (`elem` (contextTypes context)) specializationPath -- | Return the specifications valid in a given context@@ -315,15 +319,16 @@ specializedContext context specialization = SpecializedContext (specializationStart specialization `elemIndex` (contextTypes context))- (specializationEnd specialization `elemIndex` (contextTypes context))+ (specializationEnd specialization `elemIndex` (contextTypes context)) -- | 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)+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@@ -334,7 +339,7 @@ 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+ | otherwise = e1 <= e2 -- | Restrict a given context to the types of a specialization -- specializedContext :: Context -> Specialization -> Context@@ -349,7 +354,6 @@ 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@@ -358,10 +362,9 @@ -- context (a type) in which a value must be selected describeSpecializations :: Specializations -> Text describeSpecializations (Specializations ss) =- if P.null ss then- ""- else- "specializations\n" <> unlines (P.show <$> ss)+ if P.null ss+ then ""+ else "specializations\n" <> unlines (P.show <$> ss) -- | List of functions modifying some values right after they have been -- built. This enables "tweaking" the creation process with slightly@@ -381,7 +384,6 @@ -- type of the modified value describeModifiers :: Modifiers -> Text describeModifiers (Modifiers ms) =- if P.null ms then- ""- else- "modifiers for types\n" <> unlines (P.show . fst <$> ms)+ if P.null ms+ then ""+ else "modifiers for types\n" <> unlines (P.show . fst <$> ms)
src/Data/Registry/Lift.hs view
@@ -1,38 +1,36 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} -{- |- 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---}+-- |+-- 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 hiding (Nat)+import Protolude hiding (Nat) -- | 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+instance {-# OVERLAPPABLE #-} (Applicative f, b ~ f a) => ApplyVariadic f a b where applyVariadic = identity instance (Monad f, b ~ f a) => ApplyVariadic f (f a) b where applyVariadic = join -instance (Applicative f, ApplyVariadic f a' b', b ~ (f a -> b')) => ApplyVariadic f (a -> a') b where+instance {-# OVERLAPPING #-} (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@@ -50,13 +48,13 @@ 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 :: 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 ApplyVariadic2 f g a b where- applyVariadic2 :: (forall x . f x -> g x) -> a -> b+ applyVariadic2 :: (forall x. f x -> g x) -> a -> b instance (b ~ g a) => ApplyVariadic2 f g (f a) b where applyVariadic2 natfg = natfg@@ -65,14 +63,14 @@ 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 :: forall g f a b. ApplyVariadic2 f g a b => (forall x. f x -> g x) -> a -> b outTo natfg = applyVariadic2 natfg :: a -> b -- * Tagging -- | The output of some constructors can be "tagged" with a string to indicate how a given -- value was built.-newtype Tag (s :: Symbol) a = Tag { unTag :: a } deriving (Eq, Show)+newtype Tag (s :: Symbol) a = Tag {unTag :: a} deriving (Eq, Show) instance Functor (Tag s) where fmap f (Tag a) = Tag @s (f a)@@ -85,7 +83,7 @@ -- type of the constructor. For example -- data Salary = Fixed Int | Variable Int Double -- tag @"Variable" Variable :: Int -> Double -> Tag "Variable" Salary-tag :: forall (s :: Symbol) fun . (CNumArgs (CountArgs fun) fun) => fun -> Apply (Tag s) (CountArgs fun) fun+tag :: forall (s :: Symbol) fun. (CNumArgs (CountArgs fun) fun) => fun -> Apply (Tag s) (CountArgs fun) fun tag = applyLast @(Tag s) -- | ApplyLast typeclass provided by @neongreen@@ -113,9 +111,9 @@ Apply f (S n) (a -> b) = a -> Apply f n b Apply f Z a = f a -applyLast :: forall f fun . (Applicative f, CNumArgs (CountArgs fun) fun) => fun -> Apply f (CountArgs fun) fun+applyLast :: forall f fun. (Applicative f, CNumArgs (CountArgs fun) fun) => fun -> Apply f (CountArgs fun) fun applyLast = applyLast' @f (getNA :: NumArgs (CountArgs fun) fun) -applyLast' :: forall f n fun . Applicative f => NumArgs n fun -> fun -> Apply f n fun-applyLast' NAZ x = pure x+applyLast' :: forall f n fun. Applicative f => NumArgs n fun -> fun -> Apply f n fun+applyLast' NAZ x = pure x applyLast' (NAS n) f = applyLast' @f n . f
src/Data/Registry/Make.hs view
@@ -1,113 +1,118 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}+{-# 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 stack of the current types 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.- Return an error 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+{-# 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 stack of the current types 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.+-- Return an error 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 qualified Prelude (error)-import Protolude as P hiding (Constructor)-import Type.Reflection+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 Protolude as P hiding (Constructor)+import Type.Reflection+import qualified Prelude (error) -- | Make an element of type 'a' out of the registry-make :: forall a ins out . (Typeable a) => Registry ins out -> a+make :: forall a ins out. (Typeable a) => Registry ins out -> a make registry = -- if the registry is an unchecked one, built with +: -- this may fail case makeEither registry of Right a -> a- Left e -> Prelude.error (toS e)+ Left e -> Prelude.error (toS e) +-- | Make an element of type 'a' out of the registry+-- and check statically that the element can be built+makeSafe :: forall a ins out. (Typeable a, Solvable ins out) => Registry ins out -> a+makeSafe = make+ -- | Make an element of type 'a' out of the registry, for a registry -- which was possibly created with +:-makeEither :: forall a ins out . (Typeable a) => Registry ins out -> Either Text a+makeEither :: forall a ins out. (Typeable a) => Registry ins out -> Either Text a makeEither = makeEitherWithContext (Context [(someTypeRep (Proxy :: Proxy a), Nothing)]) -- * SPECIALIZED VALUES -- | make for specialized values-makeSpecialized :: forall a b ins out . (Typeable a, Typeable b) => Registry ins out -> b+makeSpecialized :: forall a b ins out. (Typeable a, Typeable b) => Registry ins out -> b makeSpecialized registry = case makeSpecializedEither @a @b registry of Right a -> a- Left e -> Prelude.error (toS e)+ Left e -> Prelude.error (toS e) -- | make for specialized values-makeSpecializedPath :: forall path b ins out . (PathToTypeReps path, Typeable b) => Registry ins out -> b+makeSpecializedPath :: forall path b ins out. (PathToTypeReps path, Typeable b) => Registry ins out -> b makeSpecializedPath registry = case makeSpecializedPathEither @path @b registry of Right a -> a- Left e -> Prelude.error (toS e)+ Left e -> Prelude.error (toS e) -- | makeEither for specialized values, in case you are using an unchecked registry-makeSpecializedEither :: forall a b ins out . (Typeable a, Typeable b) => Registry ins out -> Either Text b+makeSpecializedEither :: forall a b ins out. (Typeable a, Typeable b) => Registry ins out -> Either Text b makeSpecializedEither = makeEitherWithContext (Context [(someTypeRep (Proxy :: Proxy a), Nothing), (someTypeRep (Proxy :: Proxy b), Nothing)]) -- | makeEither for specialized values along a path, in case you are using an unchecked registry-makeSpecializedPathEither :: forall path b ins out . (PathToTypeReps path, Typeable b) => Registry ins out -> Either Text b-makeSpecializedPathEither = makeEitherWithContext (Context ((, Nothing) <$> toList (someTypeReps (Proxy :: Proxy path))))+makeSpecializedPathEither :: forall path b ins out. (PathToTypeReps path, Typeable b) => Registry ins out -> Either Text b+makeSpecializedPathEither = makeEitherWithContext (Context ((,Nothing) <$> toList (someTypeReps (Proxy :: Proxy path)))) -- | This version of make only execute checks at runtime -- this can speed-up compilation when writing tests or in ghci-makeEitherWithContext :: forall a ins out . (Typeable a) => Context -> Registry ins out -> Either Text a+makeEitherWithContext :: forall a ins out. (Typeable a) => Context -> Registry ins out -> Either Text a makeEitherWithContext context registry =- let values = _values registry- functions = _functions 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+ 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- runStackWithValues values- (makeUntyped targetType context functions specializations modifiers)-- of+ case runStackWithValues+ values+ (makeUntyped targetType context functions specializations modifiers) of Left e -> Left $- "\nThe registry is"- <> "\n\n" <> show registry- <> "=====================\n"- <> "\nCould not create a " <> show targetType <> " out of the registry:"- <> "\n\n" <> e- <> "\n\nYou can check the registry displayed above the ===== line to verify the current values and constructors\n"--+ "\nThe registry is"+ <> "\n\n"+ <> show registry+ <> "=====================\n"+ <> "\nCould not create a "+ <> show targetType+ <> " out of the registry:"+ <> "\n\n"+ <> e+ <> "\n\nYou can check the registry displayed above the ===== line to verify the current values and constructors\n" Right Nothing -> Left $- show registry- <> "\n could not create a " <> show targetType <> " out of the registry"- <> "\n\nYou can check the registry displayed above the ===== line to verify the current values and constructors\n"-- 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))+ show registry+ <> "\n could not create a "+ <> show targetType+ <> " out of the registry"+ <> "\n\nYou can check the registry displayed above the ===== line to verify the current values and constructors\n"+ 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))
src/Data/Registry/RIO.hs view
@@ -1,99 +1,12 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE UndecidableInstances #-}-{- |-- RIO is equivalent to @ResourceT (WriterT Warmup IO)@- It can be used to instantiate "components as records of functions"- where each component can allocate resources and have a "warmup phase"- to preload data or assess if it is working properly.---} module Data.Registry.RIO where -import Control.Monad.Base-import Control.Monad.Catch-import Control.Monad.Trans-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 hiding (Alt, try)---- | 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--- component 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) <$> liftIO 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)---- 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+import Control.Monad.Trans.Resource+import Data.Registry.Make+import Data.Registry.Registry+import Data.Registry.Solver+import Protolude --- | Use a RIO value and make sure that resources are closed--- Only run the action if the warmup is successful-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 ()- pure result+type RIO = ResourceT IO -- | This function must be used to run services involving a top component -- It creates the top component and invokes all warmup functions@@ -102,88 +15,21 @@ -- not depending on the Result -- -- 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)- -> m b-withRegistry registry f = liftIO $ runResourceT $ do- (a, warmup) <- runRegistryT @a registry- result <- lift . liftIO $ runWarmup warmup- lift $ f result a+withRegistry ::+ forall a b ins out m.+ (Typeable a, Contains (RIO a) out, Solvable ins out, MonadIO m, MemoizedActions out) =>+ Registry ins out ->+ (a -> IO b) ->+ m b+withRegistry registry f = liftIO $+ runResourceT (runRegistryT @a registry >>= liftIO . f) -- | 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 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---- | This runs a RIO value without closing down resources or executing startup actions-unsafeRunRIO :: (Typeable a, MonadIO m) => RIO a -> m a-unsafeRunRIO rio = liftIO $ do- is <- createInternalState- fst <$> runRIO rio (Stop is)---- | Use a RIO value and make sure that resources are closed--- Don't run the warmup-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 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 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 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 m . (Typeable a, Contains (RIO a) out, MonadIO m) => Registry ins out -> m (a, Stop)-unsafeRunWithStop = unsafeRunDynamicWithStop--unsafeRunDynamicWithStop :: forall a ins out m . (Typeable a, MonadIO m) => Registry ins out -> m (a, Stop)-unsafeRunDynamicWithStop registry = liftIO $ do- is <- createInternalState- (a, _) <- runRIO (make @(RIO a) registry) (Stop is)- pure (a, Stop is)---- | 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+runRegistryT ::+ forall a ins out .+ (Typeable a, Contains (RIO a) out, Solvable ins out, MemoizedActions out) =>+ Registry ins out ->+ ResourceT IO a+runRegistryT registry =+ liftIO (memoizeAll @RIO registry) >>= make @(RIO a)
src/Data/Registry/Registry.hs view
@@ -1,85 +1,89 @@-{-# 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-- The `<:` operator, to append functions or values to a registry:-- > registry =- > val (Config 1)- > <: val "hello"- > <: fun add1- > <: fun show1-- At the type level a list of all the function inputs and all the outputs is being kept to- check that when we add a function, all the inputs of that function can be- built by the registry. This also ensures that we cannot introduce cycles- by adding function which would require each other to build their output-- It is possible to use the `<+>` operator to "override" some configurations:-- > mocks =- > fun noLogging- > <: fun inMemoryDb- >- > mocks <+> registry+{-# 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+--+-- The `<:` operator, to append functions or values to a registry:+--+-- > registry =+-- > val (Config 1)+-- > <: val "hello"+-- > <: fun add1+-- > <: fun show1+--+-- At the type level a list of all the function inputs and all the outputs is being kept to+-- check that when we add a function, all the inputs of that function can be+-- built by the registry. This also ensures that we cannot introduce cycles+-- by adding function which would require each other to build their output+--+-- It is possible to use the `<+>` operator to "override" some configurations:+--+-- > mocks =+-- > fun noLogging+-- > <: fun inMemoryDb+-- >+-- > 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 qualified Prelude (show)-import Protolude as P hiding ((<>))-import Type.Reflection+import Data.Dynamic+import Data.Registry.Internal.Cache+import Data.Registry.Internal.Types+import Data.Registry.Lift+import Data.Registry.Solver+import Data.Semigroup ((<>))+import Protolude as P hiding ((<>))+import Type.Reflection+import qualified Prelude (show) -- | 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 :: [Type]) (outputs :: [Type]) =- Registry {- _values :: Values- , _functions :: Functions- , _specializations :: Specializations- , _modifiers :: Modifiers+data Registry (inputs :: [Type]) (outputs :: [Type]) = Registry+ { _values :: Values,+ _functions :: Functions,+ _specializations :: Specializations,+ _modifiers :: Modifiers } instance Show (Registry inputs outputs) where show (Registry vs fs ss@(Specializations ss') ms@(Modifiers ms')) =- toS . unlines $ [- "Values\n"- , describeValues vs- , "Constructors\n"- , describeFunctions fs+ toS . unlines $+ [ "Values\n",+ describeValues vs,+ "Constructors\n",+ describeFunctions fs ]- <> (if not (null ss') then [- "Specializations\n"- , describeSpecializations ss]- else [])- <> (if not (null ms') then [- "Modifiers\n"- , describeModifiers ms]- else [])+ <> ( if not (null ss')+ then+ [ "Specializations\n",+ describeSpecializations ss+ ]+ else []+ )+ <> ( if not (null ms')+ then+ [ "Modifiers\n",+ describeModifiers ms+ ]+ else []+ ) instance Semigroup (Registry inputs outputs) where- (<>) (Registry (Values vs1) (Functions fs1) (Specializations ss1) (Modifiers ms1))- (Registry (Values vs2) (Functions fs2) (Specializations ss2) (Modifiers ms2)) =- Registry (Values (vs1 <> vs2)) (Functions (fs1 <> fs2)) (Specializations (ss1 <> ss2)) (Modifiers (ms1 <> ms2))+ (<>)+ (Registry (Values vs1) (Functions fs1) (Specializations ss1) (Modifiers ms1))+ (Registry (Values vs2) (Functions fs2) (Specializations ss2) (Modifiers ms2)) =+ Registry (Values (vs1 <> vs2)) (Functions (fs1 <> fs2)) (Specializations (ss1 <> ss2)) (Modifiers (ms1 <> ms2)) instance Semigroup (Registry inputs outputs) => Monoid (Registry inputs outputs) where mempty = Registry (Values []) (Functions []) (Specializations []) (Modifiers [])@@ -87,57 +91,68 @@ -- | Append 2 registries together infixr 4 <+>+ (<+>) :: 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))+(<+>)+ (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 -- The signature checks that a constructor of type 'a' can be fully -- constructed from elements of the registry before adding it-register :: (Typeable a, IsSubset (Inputs a) out a)- => Typed a- -> Registry ins out- -> Registry (Inputs a :++ ins) (Output a ': out)+register ::+ (Typeable a, IsSubset (Inputs a) out a) =>+ Typed a ->+ Registry ins out ->+ Registry (Inputs a :++ ins) (Output a ': out) register = registerUnchecked -- | Store an element in the registry -- Internally elements are stored as 'Dynamic' values-registerUnchecked :: (Typeable a)- => Typed a- -> Registry ins out- -> Registry (Inputs a :++ ins) (Output a ': out)+registerUnchecked ::+ (Typeable a) =>+ Typed a ->+ Registry ins out ->+ Registry (Inputs a :++ ins) (Output a ': out) registerUnchecked (TypedValue v) (Registry (Values vs) functions specializations modifiers) = Registry (Values (v : vs)) functions specializations modifiers- registerUnchecked (TypedFunction f) (Registry (Values vs) (Functions fs) specializations modifiers) = Registry (Values vs) (Functions (f : fs)) specializations modifiers -- | Add an element to the Registry but do not check that the inputs of 'a' -- can already be produced by the registry infixr 5 +:+ (+:) :: (Typeable a) => Typed a -> Registry ins out -> Registry (Inputs a :++ ins) (Output a ': out) (+:) = registerUnchecked -- Unification of +: and <+> infixr 5 <:+ class AddRegistryLike a b c | a b -> c where (<:) :: a -> b -> c instance (insr ~ (ins1 :++ ins2), outr ~ (out1 :++ out2)) => AddRegistryLike (Registry ins1 out1) (Registry ins2 out2) (Registry insr outr) where (<:) = (<+>) -instance (Typeable a, IsSubset (Inputs a) out2 a, insr ~ (Inputs a :++ ins2), outr ~ (Output a : out2)) =>- AddRegistryLike (Typed a) (Registry ins2 out2) (Registry insr outr) where+instance+ (Typeable a, IsSubset (Inputs a) out2 a, insr ~ (Inputs a :++ ins2), outr ~ (Output a : out2)) =>+ AddRegistryLike (Typed a) (Registry ins2 out2) (Registry insr outr)+ where (<:) = register -instance (Typeable a, IsSubset (Inputs a) out2 a, insr ~ (Inputs a :++ ins2), outr ~ (Output a : out2)) =>- AddRegistryLike (Registry ins2 out2) (Typed a) (Registry insr outr) where+instance+ (Typeable a, IsSubset (Inputs a) out2 a, insr ~ (Inputs a :++ ins2), outr ~ (Output a : out2)) =>+ AddRegistryLike (Registry ins2 out2) (Typed a) (Registry insr outr)+ where (<:) = flip register -instance (Typeable a, IsSubset (Inputs a) '[Output b] a, Inputs b ~ '[], Typeable b, insr ~ (Inputs a :++ (Inputs b :++ '[])), outr ~ (Output a : '[Output b])) =>- AddRegistryLike (Typed a) (Typed b) (Registry insr outr) where+instance+ (Typeable a, IsSubset (Inputs a) '[Output b] a, Inputs b ~ '[], Typeable b, insr ~ (Inputs a :++ (Inputs b :++ '[])), outr ~ (Output a : '[Output b])) =>+ AddRegistryLike (Typed a) (Typed b) (Registry insr outr)+ where (<:) a b = register a (register b end) -- | Make the lists of types in the Registry unique, either for better display@@ -153,7 +168,6 @@ data ERASED_TYPES - -- | In case it is hard to show that the types of 2 registries align -- for example with conditional like -- if True then fun myFunctionWithKnownOutputs <: r else r@@ -173,11 +187,11 @@ 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 :: 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 :: 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'@@ -186,78 +200,96 @@ -- | 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 :: 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 the inputs only -- to an 'Applicative' context -- In general `funTo` should work, even with function already returning an m a -- but if this is not the case (see issue #7) then funAs can be used-funAs :: forall m a b . (ApplyVariadic1 m a b, Typeable a, Typeable b) => a -> Typed b+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, Typeable b)- => b- -> Registry ins out- -> Registry ins out-specialize b (Registry values functions (Specializations c) modifiers) = Registry- values- functions- (Specializations (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (createTypeableValue b) : c))- modifiers+specialize ::+ forall a b ins out.+ (Typeable a, Typeable b) =>+ b ->+ Registry ins out ->+ Registry ins out+specialize b (Registry values functions (Specializations c) modifiers) =+ Registry+ values+ functions+ (Specializations (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (createTypeableValue b) : c))+ modifiers -specializePath :: forall path b ins out . (PathToTypeReps path, Typeable b)- => b- -> Registry ins out- -> Registry ins out-specializePath b (Registry values functions (Specializations c) modifiers) = Registry- values- functions- (Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (createTypeableValue b) : c))- modifiers+specializePath ::+ forall path b ins out.+ (PathToTypeReps path, Typeable b) =>+ b ->+ Registry ins out ->+ Registry ins out+specializePath b (Registry values functions (Specializations c) modifiers) =+ Registry+ values+ functions+ (Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (createTypeableValue b) : c))+ modifiers -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 (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (createValue b) : c))- modifiers+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 (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (createValue b) : c))+ modifiers -specializePathVal :: forall path b ins out . (PathToTypeReps path, Typeable b, Show b)- => b- -> Registry ins out- -> Registry ins out-specializePathVal b (Registry values functions (Specializations c) modifiers) = Registry- values- functions- (Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (createValue b) : c))- modifiers+specializePathVal ::+ forall path b ins out.+ (PathToTypeReps path, Typeable b, Show b) =>+ b ->+ Registry ins out ->+ Registry ins out+specializePathVal b (Registry values functions (Specializations c) modifiers) =+ Registry+ values+ functions+ (Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (createValue b) : c))+ modifiers -specializeValTo :: forall m a b ins out . (Applicative m, Typeable a, 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 (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (liftProvidedValue @m b) : c))- modifiers+specializeValTo ::+ forall m a b ins out.+ (Applicative m, Typeable a, 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 (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (liftProvidedValue @m b) : c))+ modifiers -specializePathValTo :: forall m path b ins out . (Applicative m, PathToTypeReps path, Typeable (m b), Typeable b, Show b)- => b- -> Registry ins out- -> Registry ins out-specializePathValTo b (Registry values functions (Specializations c) modifiers) = Registry- values- functions- (Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (liftProvidedValue @m b) : c))- modifiers+specializePathValTo ::+ forall m path b ins out.+ (Applicative m, PathToTypeReps path, Typeable (m b), Typeable b, Show b) =>+ b ->+ Registry ins out ->+ Registry ins out+specializePathValTo 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 :: [Type]) where@@ -271,26 +303,34 @@ -- | 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)- => (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), createConstModifierFunction f) : mf))+tweak ::+ forall a ins out.+ (Typeable a) =>+ (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), createConstModifierFunction f) : mf)) -- * 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)+-- This section adds support for memoizing those actions -- | 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!-memoize :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a))- => Registry ins out- -> IO (Registry ins out)+memoize ::+ forall m a ins out.+ (MonadIO m, Typeable a, Typeable (m a)) =>+ Registry ins out ->+ IO (Registry ins out) memoize (Registry values functions specializations (Modifiers mf)) = do cache <- newCache @a let modifiers = Modifiers ((someTypeRep (Proxy :: Proxy (m a)), createFunction . fetch @a @m cache) : mf)@@ -300,16 +340,17 @@ -- 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)+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 :: [Type]) (ins :: [Type]) (out :: [Type]) = MemoizeRegistry { _unMemoizeRegistry :: Registry ins out }+newtype MemoizeRegistry (todo :: [Type]) (ins :: [Type]) (out :: [Type]) = 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 :: forall todo ins out. Registry ins out -> MemoizeRegistry todo ins out makeMemoizeRegistry = MemoizeRegistry @todo class MemoizedActions ls where
src/Data/Registry/Solver.hs view
@@ -1,18 +1,17 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} -{- |- Type level functions to statically assess- if a value can be built out of a Registry--}+-- |+-- Type level functions to statically assess+-- if a value can be built out of a Registry module Data.Registry.Solver where -import Data.Kind-import GHC.TypeLits+import Data.Kind+import GHC.TypeLits -- | Compute the list of input types for a function type family Inputs f :: [Type] where@@ -25,23 +24,24 @@ Output x = x -- | Compute if a constructor can be added to a registry-type family CanMake (a :: Type) (els :: [Type]) (target :: Type):: Constraint where- CanMake a '[] t = TypeError (- Text "The constructor for " :$$:- Text "" :$$:- (Text " " :<>: ShowType (Output t)) :$$:- Text "" :$$:- Text "cannot be added to the registry because" :$$:- Text "" :$$:- (Text " " :<>: ShowType (Output a)) :$$:- Text "" :$$:- Text " is not one of the registry outputs" :$$:- Text "" :$$:- (Text "The full constructor type for " :<>: ShowType (Output t) :<>: Text " is"):$$:- Text "" :$$:- ShowType t :$$:- Text ""- )+type family CanMake (a :: Type) (els :: [Type]) (target :: Type) :: Constraint where+ CanMake a '[] t =+ TypeError+ ( Text "The constructor for "+ :$$: Text ""+ :$$: (Text " " :<>: ShowType (Output t))+ :$$: Text ""+ :$$: Text "cannot be added to the registry because"+ :$$: Text ""+ :$$: (Text " " :<>: ShowType (Output a))+ :$$: Text ""+ :$$: Text " is not one of the registry outputs"+ :$$: Text ""+ :$$: (Text "The full constructor type for " :<>: ShowType (Output t) :<>: Text " is")+ :$$: Text ""+ :$$: ShowType t+ :$$: Text ""+ ) CanMake a (a ': _els) _t = () CanMake a (_b ': els) t = CanMake a els t @@ -50,6 +50,7 @@ class IsSubset (ins :: [Type]) (out :: [Type]) (target :: Type) instance IsSubset '[] out t+ instance (CanMake a out t, IsSubset els out t) => IsSubset (a ': els) out t -- | Compute if each element of a list of types@@ -69,7 +70,7 @@ Contains1 a (b ': els) t = Contains1 a els t -- | Shorthand type alias when many such constraints need to be added to a type signature-type (out :- a) = Contains a out+type out :- a = Contains a out -- | From the list of all the input types and outputs types of a registry -- Can we create all the output types?@@ -82,7 +83,7 @@ -- What we really want is typelevel sets but they are too slow for now -- https://github.com/dorchard/type-level-sets/issues/17 type family (:++) (x :: [k]) (y :: [k]) :: [k] where- '[] :++ xs = xs+ '[] :++ xs = xs (x ': xs) :++ ys = x ': (xs :++ ys) -- | Return '[a] only if it is not already in the list of types
src/Data/Registry/State.hs view
@@ -2,24 +2,24 @@ module Data.Registry.State where -import Control.Monad.Morph-import Data.Registry.Internal.Types-import Data.Registry.Lift-import Data.Registry.Registry-import Data.Registry.Solver-import Protolude+import Control.Monad.Morph+import Data.Registry.Internal.Types+import Data.Registry.Lift+import Data.Registry.Registry+import Data.Registry.Solver+import Protolude -- | Run some registry modifications in the StateT monad runS :: (MFunctor m, Monad n) => Registry ins out -> m (StateT (Registry ins out) n) a -> m n a runS r = hoist (`evalStateT` r) -- | Add an element to the registry without changing its type-addFunTo :: forall m a b ins out . (ApplyVariadic m a b, Typeable a, Typeable b, IsSubset (Inputs b) out b) => a -> Registry ins out -> Registry ins out+addFunTo :: forall m a b ins out. (ApplyVariadic m a b, Typeable a, Typeable b, IsSubset (Inputs b) out b) => a -> Registry ins out -> Registry ins out addFunTo = addToRegistry @b . funTo @m -- | Add an element to the registry without changing its type -- *** This possibly adds untracked input types / output type! ***-addFunToUnsafe :: forall m a b ins out . (ApplyVariadic m a b, Typeable a, Typeable b) => a -> Registry ins out -> Registry ins out+addFunToUnsafe :: forall m a b ins out. (ApplyVariadic m a b, Typeable a, Typeable b) => a -> Registry ins out -> Registry ins out addFunToUnsafe = addToRegistryUnsafe @b . funTo @m -- | Add an element to the registry without changing its type, in the State monad@@ -32,12 +32,12 @@ addFunUnsafeS = modify . addFunUnsafe -- | Add an element to the registry without changing its type, in the State monad-addToS :: forall n a b m ins out . (ApplyVariadic n a b, Typeable a, Typeable b, Typeable a, IsSubset (Inputs b) out b, MonadState (Registry ins out) m) => a -> m ()+addToS :: forall n a b m ins out. (ApplyVariadic n a b, Typeable a, Typeable b, Typeable a, IsSubset (Inputs b) out b, MonadState (Registry ins out) m) => a -> m () addToS = modify . addFunTo @n @a @b -- | Add an element to the registry without changing its type, in the State monad -- *** This possibly adds untracked input types / output type! ***-addToUnsafeS :: forall n a b m ins out . (ApplyVariadic n a b, Typeable a, Typeable b, Typeable a, MonadState (Registry ins out) m) => a -> m ()+addToUnsafeS :: forall n a b m ins out. (ApplyVariadic n a b, Typeable a, Typeable b, Typeable a, MonadState (Registry ins out) m) => a -> m () addToUnsafeS = modify . addFunToUnsafe @n @a @b -- | Add an element to the registry without changing its type@@ -53,7 +53,6 @@ addToRegistry :: (Typeable a, IsSubset (Inputs a) out a) => Typed a -> Registry ins out -> Registry ins out addToRegistry (TypedValue v) (Registry (Values vs) functions specializations modifiers) = Registry (Values (v : vs)) functions specializations modifiers- addToRegistry (TypedFunction f) (Registry (Values vs) (Functions fs) specializations modifiers) = Registry (Values vs) (Functions (f : fs)) specializations modifiers @@ -65,7 +64,6 @@ addToRegistryUnsafe :: (Typeable a) => Typed a -> Registry ins out -> Registry ins out addToRegistryUnsafe (TypedValue v) (Registry (Values vs) functions specializations modifiers) = Registry (Values (v : vs)) functions specializations modifiers- addToRegistryUnsafe (TypedFunction f) (Registry (Values vs) (Functions fs) specializations modifiers) = Registry (Values vs) (Functions (f : fs)) specializations modifiers
src/Data/Registry/Statistics.hs view
@@ -1,49 +1,47 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MonoLocalBinds #-} -module Data.Registry.Statistics (- module S-, makeStatistics-, makeStatisticsEither-) where+module Data.Registry.Statistics+ ( module S,+ makeStatistics,+ makeStatisticsEither,+ )+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.Registry-import Prelude (error)-import Protolude-import Type.Reflection+import Data.Registry.Internal.Make+import Data.Registry.Internal.Stack+import Data.Registry.Internal.Statistics as S+import Data.Registry.Internal.Types+import Data.Registry.Registry+import Protolude+import Type.Reflection+import Prelude (error) -- | 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)-makeStatistics :: forall a ins out . (Typeable a) => Registry ins out -> Statistics+makeStatistics :: forall a ins out. (Typeable a) => Registry ins out -> Statistics makeStatistics registry = case makeStatisticsEither @a registry of Right a -> a- Left e -> Prelude.error (toS e)+ Left e -> Prelude.error (toS e) -- | 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 :: forall a ins out. (Typeable a) => Registry ins out -> Either Text Statistics makeStatisticsEither registry =- let values = _values registry- functions = _functions 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+ 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, Nothing)]) functions specializations modifiers)-- of+ case evalStackWithValues+ values+ (makeUntyped targetType (Context [(targetType, Nothing)]) 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-+ Left $+ "could not create a " <> show targetType <> " out of the registry because " <> e <> "\nThe registry is\n"+ <> show registry other -> other
src/Data/Registry/TH.hs view
@@ -1,13 +1,14 @@-module Data.Registry.TH (- TypeclassOptions-, makeTypeclass-, makeTypeclassWith-) where+module Data.Registry.TH+ ( TypeclassOptions,+ makeTypeclass,+ makeTypeclassWith,+ )+where -import Data.Text as T (drop, splitOn)-import Language.Haskell.TH-import Language.Haskell.TH.Syntax-import Protolude hiding (Type)+import Data.Text as T (drop, splitOn)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Protolude hiding (Type) {- This module generates a typeclass for a given "record of functions". For this component:@@ -35,12 +36,12 @@ makeTypeclass = makeTypeclassWith (TypeclassOptions ("With" <>) (T.drop 1)) -- | These generation options can be used to tweak the generated names-data TypeclassOptions = TypeclassOptions {- -- adjust the typeclass name based on the component constructor name- _typeclassName :: Text -> Text- -- adjust the typeclass function names based on the component function names-, _functionName :: Text -> Text-}+data TypeclassOptions = TypeclassOptions+ { -- adjust the typeclass name based on the component constructor name+ _typeclassName :: Text -> Text,+ -- adjust the typeclass function names based on the component function names+ _functionName :: Text -> Text+ } -- | Make a typeclass using some specific generation options makeTypeclassWith :: TypeclassOptions -> Name -> DecsQ@@ -49,29 +50,29 @@ case info of TyConI (DataD _ name typeVars _ [RecC _ types] _) -> do readertInstance <- createReadertInstance typeclassNameMaker functionNameMaker name typeVars types- pure $ createTypeclass typeclassNameMaker functionNameMaker name typeVars types- <> readertInstance-+ pure $+ createTypeclass typeclassNameMaker functionNameMaker name typeVars types+ <> readertInstance TyConI (NewtypeD _ name typeVars _ (RecC _ types) _) -> do readertInstance <- createReadertInstance typeclassNameMaker functionNameMaker name typeVars types- pure $ createTypeclass typeclassNameMaker functionNameMaker name typeVars types- <> readertInstance+ pure $+ createTypeclass typeclassNameMaker functionNameMaker name typeVars types+ <> readertInstance other -> do qReport True ("can only generate a typeclass for a record of functions, got: " <> show other) pure [] --createTypeclass :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> [Dec]+createTypeclass :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr ()] -> [VarBangType] -> [Dec] createTypeclass typeclassNameMaker functionNameMaker name typeVars types = let typeclassName = modifyName typeclassNameMaker (dropQualified name) functions = fmap (makeFunctionDeclaration functionNameMaker) types- in [ClassD [] typeclassName typeVars [] functions]+ in [ClassD [] typeclassName typeVars [] functions] -- | Create an instance definition using a ReaderT instance -- instance WithLogger (ReaderT (Logger m) m) where ...-createReadertInstance :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> DecsQ+createReadertInstance :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr ()] -> [VarBangType] -> DecsQ createReadertInstance typeclassNameMaker functionNameMaker name [tvar] types =- let tvarName = case tvar of PlainTV v -> v; KindedTV v _ -> v+ let tvarName = case tvar of PlainTV v _ -> v; KindedTV v _ _ -> v typeclassName = modifyName typeclassNameMaker (dropQualified name) functions = fmap (makeFunctionInstance functionNameMaker (mkName "ReaderT")) types typeclassT = ConT typeclassName@@ -80,12 +81,14 @@ componentsTypeT = VarT components readerT = ConT (mkName "ReaderT") hasTypeT = ConT (mkName "HasType")- tvarT = VarT tvarName- in pure [InstanceD Nothing+ tvarT = VarT tvarName+ in pure+ [ InstanceD+ Nothing [AppT (AppT hasTypeT (AppT componentTypeT tvarT)) componentsTypeT] (AppT typeclassT (AppT (AppT readerT componentsTypeT) tvarT))- functions]-+ functions+ ] createReadertInstance _ _ _ tvars _ = do qReport True ("can only generate a instance for a component typeclass when it has only one type variable, got: " <> show tvars) pure []@@ -102,18 +105,17 @@ readerT = ConE runnerName component = mkName "component" numberOfParameters = countNumberOfParameters functionType- parameterNames = (\i -> mkName ("p" <> show i)) <$> [1..numberOfParameters]+ parameterNames = (\i -> mkName ("p" <> show i)) <$> [1 .. numberOfParameters] parameters = VarP <$> parameterNames firstApplication = AppE (VarE name) (AppE (VarE (mkName "getTyped")) (VarE component)) body = foldl' (\r p -> AppE r (VarE p)) firstApplication parameterNames- in- FunD functionName [Clause parameters (NormalB (AppE readerT (LamE [VarP component] body))) []]+ in FunD functionName [Clause parameters (NormalB (AppE readerT (LamE [VarP component] body))) []] -- | count the number of parameters for a function type countNumberOfParameters :: Type -> Int-countNumberOfParameters (ForallT _ _ t) = countNumberOfParameters t-countNumberOfParameters (AppT (AppT ArrowT _) t) = 1 + countNumberOfParameters t-countNumberOfParameters _ = 0+countNumberOfParameters (ForallT _ _ t) = countNumberOfParameters t+countNumberOfParameters (AppT (AppT ArrowT _) t) = 1 + countNumberOfParameters t+countNumberOfParameters _ = 0 -- | Modify a template haskell name modifyName :: (Text -> Text) -> Name -> Name@@ -121,4 +123,4 @@ -- | Remove the module name from a qualified name dropQualified :: Name -> Name-dropQualified name = maybe name (mkName . toS) (lastMay (T.splitOn "." (show name)))+dropQualified name = maybe name (mkName . toS) (lastMay (T.splitOn "." (show name)))
− src/Data/Registry/Warmup.hs
@@ -1,114 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}--{- |- 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 ((<>))-#if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)-import Protolude as P hiding ((<>))-#else-import Protolude as P hiding ((<>))-import Data.Typeable-#endif---- | 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 component--- The type of the component 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]
test/Test/Data/Registry/DotSpec.hs view
@@ -2,11 +2,11 @@ module Test.Data.Registry.DotSpec where -import Data.Registry-import Data.Text as T-import Protolude-import Test.Data.Registry.Make.SpecializationSpec-import Test.Tasty.Extensions+import Data.Registry+import Data.Text as T+import Protolude+import Test.Data.Registry.Make.SpecializationSpec+import Test.Tasty.Extensions test_dot = prop "a dot graph can be generated from a registry" $ do@@ -14,25 +14,26 @@ 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]"- , "\"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\";"- , "}"- ]+ unDot dot+ === T.unlines+ [ "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\";",+ "}"+ ]
test/Test/Data/Registry/GenSpec.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} @@ -7,34 +7,34 @@ -} module Test.Data.Registry.GenSpec where -import Data.List (partition)-import Data.Registry-import Hedgehog.Gen as Gen-import Hedgehog.Range as Range-import Protolude as P-import Test.Tasty.Extensions+import Data.List (partition)+import Data.Registry+import Hedgehog.Gen as Gen+import Hedgehog.Range as Range+import Protolude as P+import Test.Tasty.Extensions -- * DATA MODEL -newtype Company =- Company { departments :: [Department] }+newtype Company = Company {departments :: [Department]} deriving (Eq, Show) -newtype Department =- Department { employees :: [Employee] }+newtype Department = Department {employees :: [Employee]} deriving (Eq, Show) -data Employee = Employee {- name :: Name- , age :: Age- , salary :: Salary-} deriving (Eq, Show)+data Employee = Employee+ { name :: Name,+ age :: Age,+ salary :: Salary+ }+ deriving (Eq, Show) newtype Name = Name Text deriving (Eq, Show)-newtype Age = Age Int deriving (Eq, Show, Ord, Num) -data Salary =- Fixed Int+newtype Age = Age Int deriving (Eq, Show, Ord, Num)++data Salary+ = Fixed Int | Variable Int Double deriving (Eq, Show) @@ -46,7 +46,7 @@ genText :: Gen Text genText = Gen.text (Range.linear 2 10) Gen.ascii -genList :: forall a . (Typeable a) => Gen a -> Gen [a]+genList :: forall a. (Typeable a) => Gen a -> Gen [a] genList = Gen.list (Range.linear 0 3) genInt :: Gen Int@@ -70,63 +70,65 @@ -- be careful, this is NOT commutative! -- if you set a company with one department first you may end up -- with a department with no employees, generated once and forall- setDepartmentWithOneEmployee >>- setCompanyWithOneDepartment+ setDepartmentWithOneEmployee+ >> setCompanyWithOneDepartment -- | Create a registry for all generators registry =- funTo @Gen Company- <: fun (genList @Department)- <: funTo @Gen Department- <: fun (genList @Employee)- <: funTo @Gen Employee- <: funTo @Gen Age- <: funTo @Gen Fixed- <: funTo @Gen Name- <: fun genInt- <: fun genText- <: fun genDouble--test_company_with_one_employee = noShrink $ prop "generate just one employee" $ runR $ do- setMinimalCompany- company <- forall @Company- let allEmployees = company & departments >>= (& employees)- length allEmployees === 1+ funTo @Gen Company+ <: fun (genList @Department)+ <: funTo @Gen Department+ <: fun (genList @Employee)+ <: funTo @Gen Employee+ <: funTo @Gen Age+ <: funTo @Gen Fixed+ <: funTo @Gen Name+ <: fun genInt+ <: fun genText+ <: fun genDouble +test_company_with_one_employee = noShrink $+ prop "generate just one employee" $+ runR $ do+ setMinimalCompany+ company <- forall @Company+ let allEmployees = company & departments >>= (& employees)+ length allEmployees === 1 -- * WITH VARIANTS registry' =- fun (sequence . replicate @(Gen Salary) 100)- <: fun salaryGen- <: funTo @Gen (tag @"Fixed" Fixed)- <: funTo @Gen (tag @"Variable" Variable)- <: registry+ fun (sequence . replicate @(Gen Salary) 100)+ <: fun salaryGen+ <: funTo @Gen (tag @"Fixed" Fixed)+ <: funTo @Gen (tag @"Variable" Variable)+ <: registry salaryGen :: Gen (Tag "Fixed" Salary) -> Gen (Tag "Variable" Salary) -> Gen Salary salaryGen fixed variable = choice [unTag <$> fixed, unTag <$> variable] -test_with_different_salaries = noShrink $ prop "generate both fixed and variable salaries" $ runWith registry' $ do- salaries <- forall @[Salary]- let (fixed, variables) = partition isFixed salaries-- annotate "the choice operator allows us to generate both fixed and variable salaries"- not (null fixed) === True- not (null variables) === True+test_with_different_salaries = noShrink $+ prop "generate both fixed and variable salaries" $+ runWith registry' $ do+ salaries <- forall @[Salary]+ let (fixed, variables) = partition isFixed salaries + annotate "the choice operator allows us to generate both fixed and variable salaries"+ not (null fixed) === True+ not (null variables) === True -- * HELPERS -type RegistryProperty m a = forall ins out . StateT (Registry ins out) (PropertyT m) a+type RegistryProperty m a = forall ins out. StateT (Registry ins out) (PropertyT m) a -forall :: forall a m . (HasCallStack, Typeable a, Show a, Monad m) => RegistryProperty m a+forall :: forall a m. (HasCallStack, Typeable a, Show a, Monad m) => RegistryProperty m a forall = withFrozenCallStack $ get >>= P.lift . forAll . make @(Gen a) -tweakGen :: forall a m . (Typeable a, Monad m) => (Gen a -> Gen a) -> RegistryProperty m ()+tweakGen :: forall a m. (Typeable a, Monad m) => (Gen a -> Gen a) -> RegistryProperty m () tweakGen f = modify $ tweak @(Gen a) f runR :: Monad m => RegistryProperty m a -> PropertyT m a runR = runWith registry runWith :: Monad m => Registry ins out -> RegistryProperty m a -> PropertyT m a-runWith = flip evalStateT+runWith r rp = evalStateT rp r
test/Test/Data/Registry/Internal/CacheSpec.hs view
@@ -2,16 +2,16 @@ module Test.Data.Registry.Internal.CacheSpec where -import Control.Concurrent.Async-import Data.Registry.Internal.Cache-import Protolude as P-import Test.Tasty.Extensions+import Control.Concurrent.Async+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 <- newMVar (0 :: Int)- let action = modifyMVar_ ref (pure . (+1)) >> readMVar ref+ let action = modifyMVar_ ref (pure . (+ 1)) >> readMVar ref cache <- newCache -- when the action is cached it will always return the same value
test/Test/Data/Registry/Internal/DynamicSpec.hs view
@@ -1,37 +1,34 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} 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)+import Data.Dynamic+import Data.Registry.Internal.Dynamic+import Data.Registry.Internal.Types+import Data.Text as T+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+ 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@@ -40,8 +37,7 @@ -- 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 :: forall a. (Typeable a) => a -> SomeTypeRep dynType = dynTypeRep . toDyn
test/Test/Data/Registry/Internal/Gens.hs view
@@ -1,22 +1,21 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-}- {-# OPTIONS_GHC -fno-warn-missing-monadfail-instances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Test.Data.Registry.Internal.Gens where -import Data.Registry-import Hedgehog-import Protolude-import Test.Data.Registry.Internal.GensRegistry+import Data.Registry+import Hedgehog+import Protolude+import Test.Data.Registry.Internal.GensRegistry -- Hedgehog generators for the internal types registry = normalize gensRegistry -forall :: forall a . _ => PropertyT IO a+forall :: forall a. _ => PropertyT IO a forall = forAll $ gen @a -gen :: forall a . _ => Gen a+gen :: forall a. _ => Gen a gen = make registry
test/Test/Data/Registry/Internal/GensRegistry.hs view
@@ -3,75 +3,79 @@ module Test.Data.Registry.Internal.GensRegistry where -import Data.Dynamic-import Data.List.NonEmpty-import Data.Registry-import Data.Registry.Internal.Types-import Data.Text as T-import Hedgehog-import Hedgehog.Gen as Gen-import Hedgehog.Range as Range-import Prelude (show)-import Protolude-import Type.Reflection+import Data.Dynamic+import Data.List.NonEmpty+import Data.Registry+import Data.Registry.Internal.Types+import Data.Text as T+import Hedgehog+import Hedgehog.Gen as Gen+import Hedgehog.Range as Range+import Protolude+import Type.Reflection+import Prelude (show) -- Hedgehog generators for the internal types gensRegistry =- funTo @Gen UntypedRegistry- <: funTo @Gen Context- -- specializations- <: funTo @Gen Modifiers- <: fun (genList @(SomeTypeRep, ModifierFunction))- <: fun (genPair @SomeTypeRep @ModifierFunction)- <: fun genModifierFunction- <: funTo @Gen Specializations- <: fun (genList @Specialization)- <: funTo @Gen Specialization- -- functions- <: funTo @Gen Functions- <: fun (genList @Function)- <: funTo @Gen Function- <: funTo @Gen FunctionDescription- -- type reps- <: fun (genList @(SomeTypeRep, Maybe SomeTypeRep))- <: fun (genList @SomeTypeRep)- <: fun (genPair @SomeTypeRep @(Maybe SomeTypeRep))- <: fun (genPair @(NonEmpty SomeTypeRep) @Value)- <: fun (genMaybe @SomeTypeRep)- <: fun (genNonEmpty @SomeTypeRep)- <: fun genSomeTypeRep- -- values- <: funTo @Gen Values- <: fun (genList @Value)- <: funTo @Gen ProvidedValue- <: funTo @Gen ValueDescription- -- base- <: fun genDynamic- <: fun (genList @Text)- <: fun (genMaybe @Text)- <: fun genInt- <: fun genText- <: fun genTextToInt+ funTo @Gen UntypedRegistry+ <: funTo @Gen Context+ -- specializations+ <: funTo @Gen Modifiers+ <: fun (genList @(SomeTypeRep, ModifierFunction))+ <: fun (genPair @SomeTypeRep @ModifierFunction)+ <: fun genModifierFunction+ <: funTo @Gen Specializations+ <: fun (genList @Specialization)+ <: funTo @Gen Specialization+ -- functions+ <: funTo @Gen Functions+ <: fun (genList @Function)+ <: funTo @Gen Function+ <: funTo @Gen FunctionDescription+ -- type reps+ <: fun (genList @(SomeTypeRep, Maybe SomeTypeRep))+ <: fun (genList @SomeTypeRep)+ <: fun (genPair @SomeTypeRep @(Maybe SomeTypeRep))+ <: fun (genPair @(NonEmpty SomeTypeRep) @Value)+ <: fun (genMaybe @SomeTypeRep)+ <: fun (genNonEmpty @SomeTypeRep)+ <: fun genSomeTypeRep+ -- values+ <: funTo @Gen Values+ <: fun (genList @Value)+ <: funTo @Gen ProvidedValue+ <: funTo @Gen ValueDescription+ -- base+ <: fun genDynamic+ <: fun (genList @Text)+ <: fun (genMaybe @Text)+ <: fun genInt+ <: fun genText+ <: fun genTextToInt -- * 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)+data UntypedRegistry = UntypedRegistry+ { _uvalues :: Values,+ _ufunctions :: Functions,+ _uspecializations :: Specializations,+ _umodifiers :: Modifiers+ }+ deriving (Show) genValues :: Gen (Int, Values) genValues = do- value <- genInt- values <- make @(Gen Values) gensRegistry+ value <- genInt+ values <- make @(Gen Values) gensRegistry pure (value, createValue value `addValue` values) genSomeTypeRep :: Gen Value -> Gen SomeTypeRep@@ -80,10 +84,10 @@ genDynamic :: Gen Dynamic genDynamic = Gen.element [toDyn (1 :: Int), toDyn (2 :: Int), toDyn ("1" :: Text)] -genList :: forall a . Gen a -> Gen [a]+genList :: forall a. Gen a -> Gen [a] genList = Gen.list (Range.linear 1 3) -genNonEmpty :: forall a . Gen a -> Gen (NonEmpty a)+genNonEmpty :: forall a. Gen a -> Gen (NonEmpty a) genNonEmpty genA = do ls <- Gen.list (Range.linear 1 3) genA case ls of@@ -91,10 +95,10 @@ [] -> pure <$> genA as -> pure (fromList as) -genMaybe :: forall a . Gen a -> Gen (Maybe a)+genMaybe :: forall a. Gen a -> Gen (Maybe a) genMaybe = Gen.maybe -genPair :: forall a b . Gen a -> Gen b -> Gen (a, b)+genPair :: forall a b. Gen a -> Gen b -> Gen (a, b) genPair gena genb = (,) <$> gena <*> genb genInt :: Gen Int
test/Test/Data/Registry/Internal/MakeSpec.hs view
@@ -1,31 +1,31 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} 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+import Data.Registry.Internal.Make+import Data.Registry.Internal.Stack+import Data.Registry.Internal.Types+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- function <- forall @Function- target <- forall @SomeTypeRep- context' <- forall @Context- functions <- forall @Functions+ function <- forall @Function+ target <- forall @SomeTypeRep+ context' <- forall @Context+ functions <- forall @Functions specializations <- forall @Specializations- modifiers <- forall @Modifiers- values <- forall @Values+ 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, Nothing) : _contextStack context') - let result = runStackWithValues values (makeInputs function [target] context functions specializations modifiers)+ let result = runStackWithValues values (makeInputs function [target] context functions specializations modifiers) case result of- Left e -> annotateShow e >> "cycle detected!" `T.isPrefixOf` e === True+ Left e -> annotateShow e >> "cycle detected!" `T.isPrefixOf` e === True Right _ -> failure
test/Test/Data/Registry/Internal/ReflectionSpec.hs view
@@ -1,53 +1,52 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} 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+import Data.Dynamic+import Data.Registry.Internal.Reflection+import Data.Registry.Internal.Types+import Protolude as P+import Test.Tasty.Extensions+import Prelude (String) 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 -> Int)) === True isFunction (dynTypeRep $ toDyn (u :: Int -> IO Int)) === True- isFunction (dynTypeRep $ toDyn (u :: Int)) === False- isFunction (dynTypeRep $ toDyn (u :: IO Int)) === False+ 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 :: 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]"+ valDescriptionToText (describeValue ([1] :: [Int])) === "[Int]: [1]" -- user types must be shown with their full component 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 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"+ 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)
test/Test/Data/Registry/Internal/RegistrySpec.hs view
@@ -1,22 +1,22 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Test.Data.Registry.Internal.RegistrySpec where -import Data.Dynamic-import Data.Registry.Internal.Registry-import Data.Registry.Internal.Stack-import Data.Registry.Internal.Types-import Protolude as P hiding (show)-import Test.Data.Registry.Internal.Gens-import Test.Data.Registry.Internal.GensRegistry-import Test.Tasty.Extensions+import Data.Dynamic+import Data.Registry.Internal.Registry+import Data.Registry.Internal.Stack+import Data.Registry.Internal.Types+import Protolude as P hiding (show)+import Test.Data.Registry.Internal.Gens+import Test.Data.Registry.Internal.GensRegistry+import Test.Tasty.Extensions test_find_no_value = prop "no value can be found if nothing is stored in the registry" $ do- value <- forAll $ gen @Int+ value <- forAll $ gen @Int (fromValueDyn <$> findValue (valueDynTypeRep (createValue value)) mempty mempty mempty) === (Nothing :: Maybe (Maybe Int)) @@ -35,7 +35,7 @@ (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+ value <- forAll $ gen @Int (fromDynamic . funDyn <$> findConstructor (valueDynTypeRep (createValue value)) mempty) === (Nothing :: Maybe (Maybe Int)) @@ -45,8 +45,8 @@ let outputType = dynTypeRep (toDyn (1 :: Int)) - (fmap TextToInt <$> (fromDynamic . funDyn <$> findConstructor outputType functions)) ===- Just (Just (TextToInt function))+ (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@@ -61,7 +61,7 @@ (value, values) <- forAll genValues let valueType = dynTypeRep . toDyn $ value- let modifiers = Modifiers [(valueType, createConstModifierFunction (\(i:: Int) -> i + 1))]+ let modifiers = Modifiers [(valueType, createConstModifierFunction (\(i :: Int) -> i + 1))] let createdValue = createValue value let (Right stored) = execStackWithValues values (storeValue modifiers createdValue) @@ -72,10 +72,11 @@ (value, values) <- forAll genValues let valueType = dynTypeRep . toDyn $ value- let modifiers = Modifiers [- (valueType, createConstModifierFunction (\(i:: Int) -> i * 2))- , (valueType, createConstModifierFunction (\(i:: Int) -> i + 1))- ]+ let modifiers =+ Modifiers+ [ (valueType, createConstModifierFunction (\(i :: Int) -> i * 2)),+ (valueType, createConstModifierFunction (\(i :: Int) -> i + 1))+ ] let createdValue = createValue value let (Right stored) = execStackWithValues values (storeValue modifiers createdValue)
test/Test/Data/Registry/Internal/TypesSpec.hs view
@@ -3,16 +3,16 @@ module Test.Data.Registry.Internal.TypesSpec where -import Data.List.NonEmpty-import Data.Registry.Internal.Types+import Data.List.NonEmpty+import Data.Registry.Internal.Types #if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0) import Protolude as P hiding (typeOf) #else import Protolude as P #endif -import Test.Tasty.Extensions-import Type.Reflection+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 (fmap (\t -> (t, Nothing)) $ [f, e, d, c, b, a])@@ -20,8 +20,8 @@ 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))+ let s5 = specializedContext c1 (Specialization (pure c) (createValue A))+ let s6 = specializedContext c1 (Specialization (pure f) (createValue A)) (s2 < s1) === True (s3 < s1) === True@@ -33,15 +33,25 @@ (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
test/Test/Data/Registry/Make/MakeSpec.hs view
@@ -3,19 +3,21 @@ module Test.Data.Registry.Make.MakeSpec where -import Data.Registry-import Data.Text as T (length)-import Protolude-import Test.Tasty.Extensions+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 = funTo @IO newF1- <: valTo @IO (1::Int)- <: valTo @IO ("hey"::Text)+ do+ let r =+ funTo @IO newF1+ <: valTo @IO (1 :: Int)+ <: valTo @IO ("hey" :: Text) - make @(IO F1) r+ make @(IO F1) r f1 === F1 1 "hey" @@ -32,7 +34,7 @@ r <- liftIO $ try (print explosive) case r of Left (_ :: SomeException) -> assert True- Right _ -> assert False+ Right _ -> assert False add1 :: Int -> Text add1 i = show (i + 1)@@ -42,22 +44,38 @@ dda1 = T.length -- test coerce-r1 = end- <: fun dda1- <: val ("" :: Text)+r1 =+ end+ <: fun dda1+ <: val ("" :: Text) r2 :: Registry '[Text] '[Int, Text]-r2 = normalize $ end- <: fun dda1- <: val (1 :: Int)- <: val ("" :: Text)+r2 =+ normalize $+ end+ <: fun dda1+ <: val (1 :: Int)+ <: val ("" :: Text) r3 :: Registry '[Text, Text, Text] '[Int, Int, Int, Text] r3 = fun dda1 <: fun dda1 <: r2 r4 :: Registry '[Text, Text, Text] '[Int, Int, Int, Text] r4 =- if True then- r3- else- safeCoerce r2+ if True+ then r3+ else safeCoerce r2++--++test_make = test "makeSafe checks statically that a " $ do+ f1 <- liftIO $+ do+ let r =+ funTo @IO newF1+ <: valTo @IO (1 :: Int)+ <: valTo @IO ("hey" :: Text)++ make @(IO F1) r++ f1 === F1 1 "hey"
test/Test/Data/Registry/Make/MemoizeSpec.hs view
@@ -1,61 +1,68 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# 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+import Data.IORef+import Data.Registry+import Protolude hiding (C1)+import System.IO.Memoize+import Test.Tasty.Extensions -- | 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+ do+ -- create a counter for the number of instantiations+ counter <- newIORef 0 - newSingOnce <- once (newSing counter)- let r = funTo @IO newC1- <: funTo @IO newC2- <: funTo @IO newSingOnce+ newSingOnce <- once (newSing counter)+ let r =+ funTo @IO newC1+ <: funTo @IO newC2+ <: funTo @IO newSingOnce - c1 <- make @(IO C1) r- c2 <- make @(IO C2) r- pure (c1, c2)+ 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+ do+ -- create a counter for the number of instantiations+ counter <- newIORef 0 - let r = funTo @IO newC1- <: funTo @IO newC2- <: funTo @IO (newSing counter)+ let r =+ funTo @IO newC1+ <: funTo @IO newC2+ <: funTo @IO (newSing counter) - r' <- memoize @IO @Sing r- c1 <- make @(IO C1) r'- c2 <- make @(IO C2) r'- pure (c1, c2)+ 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)+ _ <- modifyIORef counter (+ 1) i <- readIORef counter pure (Sing i) @@ -65,33 +72,35 @@ 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)+ funTo @RIO App+ <: funTo @RIO newA+ <: funTo @RIO newB+ <: fun (newC messagesRef) -- just instantiate the app for its effects- withRegistry @App registry $ \_ _ -> pure ()+ withRegistry @App registry $ \_ -> pure () ms <- liftIO $ readIORef messagesRef - annotate "if memoize works properly, then only one warmup is invoked"+ annotate "if memoize works properly, then only one instantiation is invoked" ms === ["x"] -newtype A = A { doItA :: IO () }-newtype B = B { doItB :: IO () }-newtype C = C { doItC :: IO () }+newtype A = A {doItA :: IO ()} +newtype B = B {doItB :: IO ()}++newtype C = C {doItC :: IO ()}+ newA :: C -> A-newA c = A { doItA = doItC c }+newA c = A {doItA = doItC c} newB :: C -> B-newB c = B { doItB = doItC c }+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"]))+ let c = C {doItC = pure ()}+ liftIO $ modifyIORef messagesRef ("x" :) pure c -data App = App { a :: A, b :: B }+data App = App {a :: A, b :: B}
test/Test/Data/Registry/Make/SpecializationSpec.hs view
@@ -1,25 +1,29 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Test.Data.Registry.Make.SpecializationSpec where -import Data.Registry-import Protolude hiding (C1)-import Test.Tasty.Extensions+import Control.Monad.Trans.Resource+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 = fun newUseConfig2- <: fun newUseConfig1- <: val (Config 3)- let r' = specialize @UseConfig1 (Config 1) $- specialize @UseConfig2 (Config 2) r- pure (printConfig1 (make @UseConfig1 r'), printConfig2 (make @UseConfig2 r'))+ do+ let r =+ fun newUseConfig2+ <: fun newUseConfig1+ <: val (Config 3)+ 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@@ -28,12 +32,15 @@ -- 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 = fun newClient1- <: fun newUseConfig- <: val (Config 3)- let r' = specialize @Client1 (Config 1) $- specialize @UseConfig (Config 2) r- pure $ printClientConfig1 (make @Client1 r')+ do+ let r =+ fun newClient1+ <: fun newUseConfig+ <: val (Config 3)+ 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@@ -43,19 +50,21 @@ -- 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 = fun newBase- <: fun newClient1- <: fun newClient2- <: fun newUseConfig- <: val (Config 3)- let r' = specialize @Client1 (Config 1) $- specialize @Client2 (Config 2) r- pure $ printBase (make @Base r')+ do+ let r =+ fun newBase+ <: fun newClient1+ <: fun newClient2+ <: fun newUseConfig+ <: val (Config 3)+ 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 ------------+@@ -69,53 +78,62 @@ v v (config1 :: Config) (config2 :: Config) - -} newtype Config = Config Int deriving (Eq, Show) -newtype UseConfig1 = UseConfig1 { printConfig1 :: Config }-newUseConfig1 config = UseConfig1 { printConfig1 = config }+newtype UseConfig1 = UseConfig1 {printConfig1 :: Config} -newtype UseConfig2 = UseConfig2 { printConfig2 :: Config }-newUseConfig2 config = UseConfig2 { printConfig2 = config }+newUseConfig1 config = UseConfig1 {printConfig1 = config} -newtype UseConfig = UseConfig { printConfig :: Config }-newUseConfig config = UseConfig { printConfig = config }+newtype UseConfig2 = UseConfig2 {printConfig2 :: Config} -newtype Client1 = Client1 { printClientConfig1 :: Config }-newClient1 useConfig = Client1 { printClientConfig1 = printConfig useConfig }+newUseConfig2 config = UseConfig2 {printConfig2 = config} -newtype Client2 = Client2 { printClientConfig2 :: Config }-newClient2 useConfig = Client2 { printClientConfig2 = printConfig useConfig }+newtype UseConfig = UseConfig {printConfig :: Config} -newtype Base = Base { printBase :: (Config, Config) }-newBase client1 client2 = Base { printBase = (printClientConfig1 client1, printClientConfig2 client2) }+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 = funTo @RIO newBase2- <: funTo @RIO newClient1- <: funTo @RIO newClient2- <: funTo @RIO newUseConfig- <: valTo @RIO (Config 3)+ do+ let r =+ funTo @RIO newBase2+ <: funTo @RIO newClient1+ <: funTo @RIO newClient2+ <: funTo @RIO newUseConfig+ <: valTo @RIO (Config 3) - let r' = specializePathValTo @RIO @[RIO Base2, RIO Client1, RIO UseConfig] (Config 1) .- specializeValTo @RIO @(RIO UseConfig) (Config 2) $ r+ let r' =+ specializePathValTo @RIO @[RIO Base2, RIO Client1, RIO UseConfig] (Config 1)+ . specializeValTo @RIO @(RIO UseConfig) (Config 2)+ $ r - printBase2 <$> unsafeRun @Base2 r'+ printBase2 <$> runResourceT (make @(RIO Base2) r') c1 === Config 1 c2 === Config 2 c3 === Config 3 +data Base2 = Base2+ { client1 :: Client1,+ useConfig :: UseConfig,+ config3 :: Config+ } -data Base2 = Base2 {- client1 :: Client1-, useConfig :: UseConfig-, config3 :: Config-} newBase2 = Base2 printBase2 Base2 {..} = (printClientConfig1 client1, printConfig useConfig, config3)@@ -145,53 +163,57 @@ 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"+ 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)-+ (app & sql & sqlConfig) === ("for sql in general" :: Text) appRegistry :: Registry _ _ appRegistry =- specializeVal @Sql (SupervisorConfig "for sql in general") .- specializePathVal @[StatsStore, Sql] (SupervisorConfig "for sql under the stats store") .- specializeVal @TwitterClient (SupervisorConfig "for the twitter client") $- fun App- <: fun newStatsStore- <: fun newTwitterClient- <: fun newSql- <: fun newSupervisor- <: val (SupervisorConfig "default")+ specializeVal @Sql (SupervisorConfig "for sql in general")+ . specializePathVal @[StatsStore, Sql] (SupervisorConfig "for sql under the stats store")+ . specializeVal @TwitterClient (SupervisorConfig "for the twitter client")+ $ fun App+ <: fun newStatsStore+ <: fun newTwitterClient+ <: fun newSql+ <: fun newSupervisor+ <: val (SupervisorConfig "default") -data App = App {- sql :: Sql-, twitterClient :: TwitterClient-, supervisor :: Supervisor-, statsStore :: StatsStore-}+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 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 }+newSupervisor (SupervisorConfig n) = Supervisor {supervisorConfig = n} newSql :: Supervisor -> Sql-newSql s = Sql { sqlConfig = supervisorConfig s }+newSql s = Sql {sqlConfig = supervisorConfig s} newTwitterClient :: Supervisor -> TwitterClient-newTwitterClient s = TwitterClient { twitterConfig = supervisorConfig s }+newTwitterClient s = TwitterClient {twitterConfig = supervisorConfig s} newStatsStore :: TwitterClient -> Sql -> Supervisor -> StatsStore-newStatsStore client sql supervisor = StatsStore {- statsStoreConfig = (twitterConfig client, sqlConfig sql, supervisorConfig supervisor)-}+newStatsStore client sql supervisor =+ StatsStore+ { statsStoreConfig = (twitterConfig client, sqlConfig sql, supervisorConfig supervisor)+ } -- | Case 6 (taken from a real case...) test_specialization_6 = test "specialized values must not be affected by memoization" $ do@@ -199,46 +221,52 @@ r <- aRegistryIO make @(IO SomeData) r - (someData & toOverride & toOverrideConfig) === ("specialized config" :: Text)+ (someData & toOverride & toOverrideConfig) === ("specialized config" :: Text) (someData & toKeepDefault & toKeepDefaultConfig) === ("default config" :: Text) +data SomeData = SomeData+ { toKeepDefault :: ToKeepDefault,+ toOverride :: ToOverride,+ inCommon :: InCommon+ } -data SomeData = SomeData {- toKeepDefault :: ToKeepDefault-, toOverride :: ToOverride-, inCommon :: InCommon-}+newtype ToOverride = ToOverride {toOverrideConfig :: Text} -newtype ToOverride = ToOverride { toOverrideConfig :: Text }-newtype ToKeepDefault = ToKeepDefault { toKeepDefaultConfig :: Text }-newtype InCommon = InCommon { config :: SomeConfig }+newtype ToKeepDefault = ToKeepDefault {toKeepDefaultConfig :: Text} +newtype InCommon = InCommon {config :: SomeConfig}+ newtype SomeConfig = SomeConfig Text deriving (Eq, Show) newToKeepDefault :: InCommon -> ToKeepDefault-newToKeepDefault (InCommon (SomeConfig t)) = ToKeepDefault { toKeepDefaultConfig = t }+newToKeepDefault (InCommon (SomeConfig t)) = ToKeepDefault {toKeepDefaultConfig = t} newToOverride :: InCommon -> ToOverride-newToOverride (InCommon (SomeConfig t)) = ToOverride { toOverrideConfig = t }+newToOverride (InCommon (SomeConfig t)) = ToOverride {toOverrideConfig = t} aRegistryIO :: IO (Registry _ _)-aRegistryIO = memoizeAll @IO $- specializePathValTo @IO @[IO ToOverride, IO InCommon] (SomeConfig "specialized config") $- funTo @IO SomeData- <: funTo @IO newToKeepDefault- <: funTo @IO newToOverride- <: funTo @IO InCommon- <: valTo @IO (SomeConfig "default config")+aRegistryIO =+ memoizeAll @IO $+ specializePathValTo @IO @[IO ToOverride, IO InCommon] (SomeConfig "specialized config") $+ funTo @IO SomeData+ <: funTo @IO newToKeepDefault+ <: funTo @IO newToOverride+ <: funTo @IO InCommon+ <: fun (\(c:: IO SomeConfig) -> InCommon <$> c)+ <: valTo @IO (SomeConfig "default config") test_make_specialized_values = test "specialized values can be made" $ do- let r = fun newBase2+ let r =+ fun newBase2 <: fun newClient2 <: fun newClient1 <: fun newUseConfig <: val (Config 3) - let r' = specializePathVal @[Base2, Client1, UseConfig] (Config 1) .- specializeVal @UseConfig (Config 2) $ r+ let r' =+ specializePathVal @[Base2, Client1, UseConfig] (Config 1)+ . specializeVal @UseConfig (Config 2)+ $ r makeSpecialized @UseConfig r' === Config 2 makeSpecializedPath @[Base2, Client1, UseConfig] r' === Config 1
test/Test/Data/Registry/Make/TweakingSpec.hs view
@@ -3,42 +3,48 @@ module Test.Data.Registry.Make.TweakingSpec where -import Data.Registry-import Data.Registry.Internal.Types-import Protolude-import Test.Tasty.Extensions+import Data.Registry+import Data.Registry.Internal.Types+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 = fun newAppUsingConfig1- <: fun newUseConfig1- <: val (Config 1)+ do+ let r =+ fun newAppUsingConfig1+ <: fun newUseConfig1+ <: val (Config 1) - let r' = tweak (\(UseConfig1 _) -> UseConfig1 (Config 10)) r- pure (printAppConfig (make @AppUsingConfig1 r'))+ 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 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 }+newtype UseConfig1 = UseConfig1 {printConfig1 :: Config} +newUseConfig1 config = UseConfig1 {printConfig1 = config}+ -- * ========= test_tweak_non_lossy = test "a modified value must not lose its context, specialization or dependencies" $ do (a, stats) <- liftIO $- do let r = fun A- <: fun B- <: val (C 1)+ do+ let r =+ fun A+ <: fun B+ <: val (C 1) - let r' = specialize @A @C (C 2) r- let r'' = tweak (\(B (C _)) -> B (C 3)) r'- pure (make @A r'', makeStatistics @A r'')+ let r' = specialize @A @C (C 2) r+ let r'' = tweak (\(B (C _)) -> B (C 3)) r'+ pure (make @A r'', makeStatistics @A r'') -- The specialized value was 2 but after tweaking it is 3 a === A (B (C 3))@@ -51,6 +57,8 @@ -- this seems weird but a value is in the list of its dependencies (not . null) (valDependencies <$> cValue) === True -newtype A = A B deriving (Eq, Show)-newtype B = B C deriving (Eq, Show)+newtype A = A B deriving (Eq, Show)++newtype B = B C deriving (Eq, Show)+ newtype C = C Int deriving (Eq, Show)
test/Test/Data/Registry/MonadRandomSpec.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-@@ -12,14 +12,14 @@ -} module Test.Data.Registry.MonadRandomSpec where -import Control.Monad.Random.Class as R-import Control.Monad.Trans.Random.Lazy-import Data.IORef-import qualified Data.List as L-import Data.Registry-import Protolude as P-import System.Random as R-import Test.Tasty.Extensions+import Control.Monad.Random.Class as R+import Control.Monad.Trans.Random.Lazy+import Data.IORef+import qualified Data.List as L+import Data.Registry+import Protolude as P+import System.Random as R+import Test.Tasty.Extensions -- Let's say you have this function coming from a library -- It has a MonadRandom constraint but you would like to create a@@ -29,22 +29,26 @@ useMonadRandom = R.getRandom -- For example this Client component might require for its implementation--- the `useMonadRandomFunction`-newtype Client = Client { runClient :: IO Int }+-- the `useMonadRandom` function+newtype Client = Client {runClient :: IO Int} -- | What we see here is that the Client component can be implemented -- with a RandomGenerator component which will provide a way to call -- the library function having the MonadRandom constraint newClient :: RandomGenerator -> Client-newClient RandomGenerator {..} = Client {- runClient = runRandom useMonadRandom-}+newClient RandomGenerator {..} = Client {..}+ where+ runClient :: IO Int+ runClient = runRandom useMonadRandom+ -- This is the RandomGenerator component -- it reuses the RandT monad which "implements" MonadRandom given a specific generator -- it is defined for a given RandomGen type which we don't need to expose-data RandomGenerator = forall g . RandomGen g => RandomGenerator {- runRandom :: forall a . RandT g IO a -> IO a-}+data RandomGenerator = forall g.+ RandomGen g =>+ RandomGenerator+ { runRandom :: forall a. RandT g IO a -> IO a+ } -- | Production Random generator component using the global StdGen newRandomGenerator :: IO RandomGenerator@@ -53,22 +57,27 @@ -- | Random generation is "stateful" in the sense that you get a new -- generator each time you generate a random value. -- In this implementation we store this generator with a hidden IORef--- (which probably be an MVar if we use the RandomGenerator concurrently)+-- (which should probably be an MVar if we use the RandomGenerator concurrently) makeRandomGenerator :: (RandomGen g) => g -> IO RandomGenerator makeRandomGenerator gen = do ref <- newIORef gen- pure $ RandomGenerator (\a ->- do g <- readIORef ref- (r, g') <- runRandT a g- _ <- writeIORef ref g'- pure r)+ pure $+ RandomGenerator+ ( \a ->+ do+ g <- readIORef ref+ (r, g') <- runRandT a g+ _ <- writeIORef ref g'+ pure r+ ) -- * We can now define other ways to generate random values -- | Configuration for generators returning pre-determined values-data RandomGeneratorConfig = RandomGeneratorConfig {- seed :: Int-} deriving (Eq, Show)+newtype RandomGeneratorConfig = RandomGeneratorConfig+ { seed :: Int+ }+ deriving (Eq, Show) -- | All the values for this generator are deterministic and determined by -- the seed in the configuration@@ -85,12 +94,12 @@ -- | The registry to use for production looks like this -- It uses the global StdGen registryProd =- funTo @IO newClient- <: fun newRandomGenerator+ funTo @IO newClient+ <: fun newRandomGenerator -- | And now some tests test_client_function_with_random_values = test "a function using MonadRandom can be executed with the RandomGenerator component and return random values" $ do- client <- liftIO $ make @(IO Client) registryProd+ client <- liftIO $ make @(IO Client) registryProd results <- liftIO $ replicateM 10 $ client & runClient annotateShow results@@ -100,26 +109,26 @@ test_client_function_with_seeded_values = test "a function using MonadRandom can be executed with the RandomGenerator component and return predetermined values" $ do let registry' =- funTo @IO (newSeededRandomGenerator (RandomGeneratorConfig 1))- <: registryProd+ funTo @IO (newSeededRandomGenerator (RandomGeneratorConfig 1))+ <: registryProd - client <- liftIO $ make @(IO Client) registry'+ client <- liftIO $ make @(IO Client) registry' results <- liftIO $ replicateM 10 $ client & runClient annotateShow results - -- everytime we call the generator we get different values but the same list- take 3 results === [7918028818325808681, 3944251743029676875, 4139876178697185090]+ -- every time we call the generator we get different values but the same list+ take 3 results === [-2241774542048937483, 8251698951335059867, 8873074891056462818] test_client_function_with_fixed_values = test "a function using MonadRandom can be executed with the RandomGenerator component can return always the same value" $ do let registry' =- funTo @IO (newFixedRandomGenerator (RandomGeneratorConfig 1))- <: registryProd+ funTo @IO (newFixedRandomGenerator (RandomGeneratorConfig 1))+ <: registryProd - client <- liftIO $ make @(IO Client) registry'+ client <- liftIO $ make @(IO Client) registry' results <- liftIO $ replicateM 10 $ client & runClient annotateShow results - -- everytime we call the generator we get the same value+ -- every time we call the generator we get the same value length (L.nub results) === 1
− test/Test/Data/Registry/RIOSpec.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# OPTIONS_GHC -fno-warn-deprecations #-}--module Test.Data.Registry.RIOSpec where--import Data.IORef-import Data.Registry-import Protolude as P-import Test.Tasty.Extensions--test_close_resource = prop "RIO resources must be closed, with warmup" $ do- ref <- liftIO $ newIORef []- let rio = do- ref' <- allocate (pure ref) (\ref' -> modifyIORef ref' (<>["close"]))- warmupWith (warmupOf ("test"::Text) $ modifyIORef ref (<>["start"]))- pure ref'-- res <- liftIO $ withRIO rio $ \ref' -> modifyIORef ref' (<>["use"])- content <- liftIO $ readIORef ref-- isSuccess res === True- content === ["start", "use", "close" :: Text]--test_close_resource_no_warmup = prop "RIO resources must be closed" $ do-- let rio = do- ref <- allocate (newIORef []) (\ref -> modifyIORef ref (<>["close"]))- liftIO $ modifyIORef ref (<>["start"])- pure ref-- ref <- liftIO $ withNoWarmupRIO rio $ \ref -> modifyIORef ref (<>["use"]) $> ref- content <- liftIO $ readIORef ref- content === ["start", "use", "close" :: Text]
test/Test/Data/Registry/RegistrySpec.hs view
@@ -1,19 +1,19 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Test.Data.Registry.RegistrySpec where -import Data.IORef-import Data.Registry-import Protolude as P-import Test.Tasty.Extensions+import Data.IORef+import Data.Registry+import Protolude as P+import Test.Tasty.Extensions test_create_value_with_no_args_constructor = prop "no args constructors are considered as functions" $ do- ref <- liftIO $ newIORef ("" :: Text)+ ref <- liftIO $ newIORef ("" :: Text) let registry' = funTo @IO refLogger +: funTo @IO ref +: registry Logger {..} <- liftIO $ make @(IO Logger) registry'@@ -24,7 +24,7 @@ -- * -newtype Logger = Logger { info :: Text -> IO () }+newtype Logger = Logger {info :: Text -> IO ()} newLogger :: IO Logger newLogger = pure (Logger print)@@ -33,26 +33,25 @@ refLogger ref = Logger (writeIORef ref) registry =- fun newLogger- +: end-+ fun newLogger+ +: end -- * COMPILATION CHECK WITH THE <: operator registry1 :: Registry '[] '[Int, Text]-registry1 = normalize $- val (1::Int)- <: (val ("t"::Text) +: end)- <: (val ("t"::Text) +: end)- <: val ("t"::Text)+registry1 =+ normalize $+ val (1 :: Int)+ <: (val ("t" :: Text) +: end)+ <: (val ("t" :: Text) +: end)+ <: val ("t" :: Text) -- * COMPILATION CHECK LIFTING (see #7) - a :: Int -> Int -> IO Int a _ _ = pure 0 -b :: Int -> Int -> RIO Int+b :: Int -> Int -> RIO Int b = outTo @RIO liftIO a c :: RIO Int -> RIO Int -> RIO Int@@ -61,7 +60,7 @@ -- here the result of outTo needs to be explicit -- otherwise the type of d is RIO (Int -> Int -> RIO Int) d :: RIO Int -> RIO Int -> RIO Int-d = allTo @RIO (outTo @RIO liftIO a :: Int -> Int -> RIO Int)+d = allTo @RIO (outTo @RIO liftIO a :: Int -> Int -> RIO Int) -- to avoid the issue with type inference above, we can use argsTo e :: RIO Int -> RIO Int -> RIO Int
test/Test/Data/Registry/SimpleExamples.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-@@ -6,22 +6,23 @@ -} module Test.Data.Registry.SimpleExamples where -import Data.Registry-import Data.Text as T (length)-import Protolude hiding (C1)-+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 ()-}+data Logging = Logging+ { info :: Text -> IO (),+ debug :: Text -> IO ()+ } -logging = make @Logging (fun Logging { info = print, debug = print } +: end)+logging = make @Logging (fun Logging {info = print, debug = print} +: end) -- | Simple datatypes which can be used in a registry newtype Text1 = Text1 Text deriving (Eq, Show)+ newtype Text2 = Text2 Text deriving (Eq, Show)+ newtype Int1 = Int1 Int deriving (Eq, Show) -- | values and functions@@ -32,7 +33,7 @@ add1 i = show (i + 1) add2 :: Int -> Text -> Text1-add2 i j = Text1 (show (i+1) <> j)+add2 i j = Text1 (show (i + 1) <> j) text1 :: Text text1 = "text1"@@ -41,12 +42,13 @@ toText2 (Text1 t) = Text2 t registry1 :: Registry [Text1, Text, Int] [Text2, Text1, Text, Int]-registry1 = normalize $- fun toText2- <: fun add2- <: fun text1- <: fun add1- <: val int1+registry1 =+ normalize $+ fun toText2+ <: fun add2+ <: fun text1+ <: fun add1+ <: val int1 countSize :: Text -> Maybe Int countSize t = Just (T.length t)@@ -65,15 +67,16 @@ countSize1 t = Int1 (T.length t) registry2 =- fun countSize1- <: fun add1- <: fun int1+ fun countSize1+ <: fun add1+ <: fun int1 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@@ -84,9 +87,9 @@ unknown :: Double -> Text1 unknown _ = Text1 "text1" - -- | This does not compile because we need a double -- to make Text1 and it is not in the list of outputs+ {- registry3 :: Registry [Double, Int, Text] [Int, Text1, Text, Int1] registry3 =@@ -98,10 +101,12 @@ -- | Example with an optional configuration -- The ProductionComponent will only be used if the ServiceConfig says we are in production-newtype ProductionComponent = ProductionComponent { doItInProduction :: IO () }+newtype ProductionComponent = ProductionComponent {doItInProduction :: IO ()}+ data ProductionConfig = ProductionConfig deriving (Eq, Show) -newtype Service = Service { service :: IO () }+newtype Service = Service {service :: IO ()}+ data ServiceConfig = InProd | InDev deriving (Eq, Show) -- | Production component definition@@ -117,13 +122,13 @@ -- | Service component definition -- It uses a builder for the ProductionComponent and only uses it in production newService :: ServiceConfig -> Tag "builder" (ProductionConfig -> ProductionComponent) -> Service-newService InDev _ = Service { service = print ("dev" :: Text) }-newService InProd f = Service { service = doItInProduction (unTag f ProductionConfig) }+newService InDev _ = Service {service = print ("dev" :: Text)}+newService InProd f = Service {service = doItInProduction (unTag f ProductionConfig)} registryWithOptionalComponents =- fun newService- <: fun newProductionComponentBuilder- <: fun logging- <: val InDev+ fun newService+ <: fun newProductionComponentBuilder+ <: fun logging+ <: val InDev makeService = make @Service registryWithOptionalComponents
test/Test/Data/Registry/SmallExample.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-@@ -9,48 +9,55 @@ -} module Test.Data.Registry.SmallExample where -import Data.Registry-import Data.Text (splitOn)-import Protolude as P-import Test.Tasty.Extensions hiding (run)+import Data.Registry+import Data.Text (splitOn)+import Protolude as P+import Test.Tasty.Extensions hiding (run) -- | Components of the application -- - a Logger -- - an interface to S3 -- - a lines counter -- - the top level application-newtype Logger = Logger {- info :: Text -> IO ()-} deriving Typeable+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+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+newtype S3 = S3+ { store :: Text -> IO ()+ }+ deriving (Typeable) -data S3Config = S3Config {- bucket :: Text-, key :: Text-} deriving (Eq, Show, Typeable)+data S3Config = S3Config+ { bucket :: Text,+ key :: Text+ }+ deriving (Eq, Show, Typeable) newS3 :: MonadIO m => S3Config -> Logger -> m S3-newS3 config logger = pure $ S3 $- const $ info logger $ "storing on S3 with config " <> P.show config+newS3 config logger =+ pure $+ S3 $+ const $ info logger $ "storing on S3 with config " <> P.show config -newtype Application = Application {- run :: Text -> IO Int-} deriving Typeable+newtype Application = Application+ { run :: Text -> IO Int+ }+ deriving (Typeable) newApplication :: MonadIO m => Logger -> LinesCounter -> S3 -> m Application newApplication Logger {..} LinesCounter {..} S3 {..} = pure . Application $ \t -> do@@ -63,11 +70,11 @@ -- | Create a registry for all constructors registry =- funTo @IO (newApplication @IO)- <: funTo @IO (newS3 @IO)- <: funTo @IO noLogging- <: funTo @IO newLinesCounter- <: valTo @IO (S3Config "bucket" "key")+ funTo @IO (newApplication @IO)+ <: funTo @IO (newS3 @IO)+ <: funTo @IO noLogging+ <: funTo @IO newLinesCounter+ <: valTo @IO (S3Config "bucket" "key") -- | To create the application you call `make` for the `Application` type -- with the registry above@@ -78,5 +85,5 @@ test_create = test "create the application" $ do app <- liftIO createApplication -- nothing should crash!- r <- liftIO $ run app "hello\nworld"+ r <- liftIO $ run app "hello\nworld" r === 2
test/Test/Data/Registry/THSpec.hs view
@@ -1,55 +1,57 @@-{-# LANGUAGE DataKinds #-}- {-# LANGUAGE StrictData #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Test.Data.Registry.THSpec where -import Data.Generics.Product.Typed-import Data.Registry.TH-import Protolude-import Universum ((...))+import Data.Generics.Product.Typed+import Data.Registry.TH+import Protolude+import Universum ((...)) -- * Example of TemplateHaskell usage to create the typeclass corresponding to a component -- | We define 2 low-level components: Logger and Tracer -- We make the corresponding typeclasses-data Logger m = Logger {- -- a function taking 2 arguments- _info :: Text -> Text -> m ()- -- a function having a constraint-, _error :: forall a . (Monoid a) => a -> Text -> m ()-}+data Logger m = Logger+ { -- a function taking 2 arguments+ _info :: Text -> Text -> m (),+ -- a function having a constraint+ _error :: forall a. (Monoid a) => a -> Text -> m ()+ } makeTypeclass ''Logger -newtype Tracer m = Tracer {- _traceIt :: Text -> m ()-}+newtype Tracer m = Tracer+ { _traceIt :: Text -> m ()+ } makeTypeclass ''Tracer -- | Now we make a component which is going to use both components-newtype Service m = Service {- doIt :: Int -> Text -> m ()-}+newtype Service m = Service+ { doIt :: Int -> Text -> m ()+ } newService :: Monad m => Logger m -> Tracer m -> Service m-newService logger tracer = Service {- doIt = run ... implementService-} where+newService logger tracer =+ Service+ { doIt = run ... implementService+ }+ where -- the typeclass instances can be resolved by using a Reader containing -- a tuple with all the components run = flip runReaderT (logger, tracer) -- | Implement the service using typeclasses implementService ::- Monad m- => WithLogger m- => WithTracer m- => Int- -> Text- -> m ()+ Monad m =>+ WithLogger m =>+ WithTracer m =>+ Int ->+ Text ->+ m () implementService n t = do info "doing it" t traceIt (show n)
− test/Test/Data/Registry/WarmupSpec.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}--module Test.Data.Registry.WarmupSpec where--import Control.Monad.Catch-import Data.IORef-import Data.Registry-import Prelude (show)-import Protolude-import Test.Tasty.Extensions--test_runBoth1 =- prop "all results are collected when running 2 warmup 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"]--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)-- void $ withRIO (make @(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- show (Error t) = toS t--instance Exception Error--genResult :: Gen Result-genResult =- choice [genEmpty, genFailed, genOk]--genEmpty = pure Empty-genFailed = failed <$> element ["homer", "marge", "bart"]-genOk = ok <$> element ["green", "blue", "red"]
test/Test/Tasty/Extensions.hs view
@@ -1,61 +1,61 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# 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.+{-# OPTIONS_GHC -fno-warn-orphans #-} --}-module Test.Tasty.Extensions (- module Hedgehog-, module Tasty-, gotException-, groupByModuleName-, minTestsOk-, noShrink-, prop-, run-, runOnly-, test-, withSeed-) where+-- |+--+-- 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,+ groupByModuleName,+ minTestsOk,+ noShrink,+ prop,+ run,+ runOnly,+ test,+ withSeed,+ )+where -import Data.MultiMap-import GHC.Stack-import Hedgehog as Hedgehog hiding (test)-import Hedgehog.Gen as Hedgehog hiding (discard, print)-import qualified Prelude as Prelude-import Protolude hiding (empty, toList, (.&.))-import System.Environment-import Test.Tasty as Tasty-import Test.Tasty.Hedgehog as Tasty-import Test.Tasty.Options as Tasty-import Test.Tasty.Providers as Tasty (singleTest)-import Test.Tasty.Runners as Tasty (foldSingle, foldTestTree, trivialFold, TestTree(..))+import Data.MultiMap+import GHC.Stack+import Hedgehog as Hedgehog hiding (test)+import Hedgehog.Gen as Hedgehog hiding (discard, print)+import Protolude hiding (empty, toList, (.&.))+import System.Environment+import Test.Tasty as Tasty+import Test.Tasty.Hedgehog as Tasty+import Test.Tasty.Options as Tasty+import Test.Tasty.Providers as Tasty (singleTest)+import Test.Tasty.Runners as Tasty (TestTree (..), foldSingle, foldTestTree, trivialFold)+import qualified Prelude as Prelude -- | Create a Tasty test from a Hedgehog property prop :: HasCallStack => TestName -> PropertyT IO () -> TestTree prop name p = let aModuleName = getModuleName- in withFrozenCallStack . localOption (ModuleName (toS aModuleName)) $- testProperty name (Hedgehog.property p)+ in withFrozenCallStack $ localOption (ModuleName (toS aModuleName)) $+ 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 . noShrink $ prop name p) -gotException :: forall a . (HasCallStack, Show a) => a -> PropertyT IO ()+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+ Left _ -> assert True Right _ -> annotateShow ("excepted an exception" :: Text) >> assert False -- * Parameters@@ -78,11 +78,18 @@ -- group all the tests with that option into the same test group groupByModuleName :: TestTree -> TestTree groupByModuleName testTree =- let grouped = assocs $ foldTestTree (trivialFold { foldSingle = \os n t ->- let (ModuleName aModuleName) = lookupOption os :: ModuleName- in insert (toS aModuleName) (setOptionSet os $ singleTest n t) empty- }) mempty testTree- in TestGroup "All" (uncurry TestGroup <$> grouped)+ let grouped =+ assocs $+ foldTestTree+ ( trivialFold+ { foldSingle = \os n t ->+ let (ModuleName aModuleName) = lookupOption os :: ModuleName+ in insert (toS aModuleName) (setOptionSet os $ singleTest n t) empty+ }+ )+ mempty+ testTree+ in TestGroup "All" (uncurry TestGroup <$> grouped) instance (Ord k) => Semigroup (MultiMap k v) where (<>) m1 m2 = fromList (toList m1 <> toList m2)@@ -99,15 +106,15 @@ -- added in that function setOptionSet :: OptionSet -> TestTree -> TestTree setOptionSet os =- localOption (lookupOption os :: HedgehogTestLimit) .- localOption (lookupOption os :: HedgehogShrinkLimit) .- localOption (lookupOption os :: HedgehogReplay)+ localOption (lookupOption os :: HedgehogTestLimit)+ . localOption (lookupOption os :: HedgehogShrinkLimit)+ . localOption (lookupOption os :: HedgehogReplay) getModuleName :: HasCallStack => Prelude.String getModuleName =- case getCallStack callStack of- ((_, loc):_) -> srcLocModule loc- _other -> "root"+ case getCallStack callStack of+ ((_, loc) : _) -> srcLocModule loc+ _other -> "root" -- | Option describing the current module name newtype ModuleName = ModuleName Text deriving (Eq, Show)
test/Test/Tutorial/Application.hs view
@@ -1,101 +1,106 @@ {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StrictData #-}- +{-# LANGUAGE StrictData #-}+ module Test.Tutorial.Application where import qualified Data.ByteString.Char8 as BS8-import Protolude-import System.Directory (doesFileExist)-import System.Random+import Protolude+import System.Directory (doesFileExist)+import System.Random -data App = App {- userInput :: UserInput IO-, secretReader :: SecretReader IO-, rng :: Rng IO-, console :: Console IO-}+data App = App+ { userInput :: UserInput IO,+ secretReader :: SecretReader IO,+ rng :: Rng IO,+ console :: Console IO+ } startApp :: App -> IO ()-startApp app@App{..} = do+startApp app@App {..} = do userAnswer <- askQuestion userInput continue <- case userAnswer of Maybe -> randomBool rng- No -> pure False- Yes -> pure True+ No -> pure False+ Yes -> pure True - if continue then- do secret <- readSecret secretReader- case secret of- Nothing -> write console "Sorry I actually don't know"- Just s -> do- write console ("the answer is " <> s)- startApp app- else- write console "bye"+ if continue+ then do+ secret <- readSecret secretReader+ case secret of+ Nothing -> write console "Sorry I actually don't know"+ Just s -> do+ write console ("the answer is " <> s)+ startApp app+ else write console "bye" -data Logger m = Logger {- info :: Text -> m ()-, error :: Text -> m ()-}+data Logger m = Logger+ { info :: Text -> m (),+ error :: Text -> m ()+ } newLogger :: Logger IO-newLogger = Logger {- info = \t -> print $ "[INFO] " <> t-, error = \t -> print $ "[ERROR] " <> t-}+newLogger =+ Logger+ { info = \t -> print $ "[INFO] " <> t,+ error = \t -> print $ "[ERROR] " <> t+ } data UserAnswer = Yes | No | Maybe deriving (Eq, Show) -data UserInput m = UserInput {- askQuestion :: m UserAnswer-}+data UserInput m = UserInput+ { askQuestion :: m UserAnswer+ } newUserInput :: Console IO -> UserInput IO newUserInput console =- let userInput = UserInput {- askQuestion = do- write console "Do you want to know the answer to Life, the Universe and Everything? (Yes/No/Maybe)"- answer <- read console- case answer of- "Yes" -> pure Yes- "No" -> pure No- "Maybe" -> pure Maybe- _ -> write console "Please enter Yes, No or Maybe" >> askQuestion userInput- }+ let userInput =+ UserInput+ { askQuestion = do+ write console "Do you want to know the answer to Life, the Universe and Everything? (Yes/No/Maybe)"+ answer <- read console+ case answer of+ "Yes" -> pure Yes+ "No" -> pure No+ "Maybe" -> pure Maybe+ _ -> write console "Please enter Yes, No or Maybe" >> askQuestion userInput+ } in userInput -data Rng m = Rng {- randomBool :: m Bool-}+data Rng m = Rng+ { randomBool :: m Bool+ } newRng :: Logger IO -> Rng IO-newRng logger = Rng {- randomBool = do- b <- randomIO- info logger ("generated a random boolean " <> show b)- pure b-}+newRng logger =+ Rng+ { randomBool = do+ b <- randomIO+ info logger ("generated a random boolean " <> show b)+ pure b+ } -- Get the secret answer and return Nothing if not found-data SecretReader m = SecretReader {- readSecret :: m (Maybe Text)-}+data SecretReader m = SecretReader+ { readSecret :: m (Maybe Text)+ } data SecretReaderConfig = SecretReaderConfig Text deriving (Eq, Show) newSecretReader :: SecretReaderConfig -> Logger IO -> SecretReader IO-newSecretReader (SecretReaderConfig path) logger = SecretReader {- readSecret = do- exists <- doesFileExist (toS path)- if exists then Just . decodeUtf8 <$> BS8.readFile (toS path)- else error logger ("file does not exist at " <> path) $> Nothing-}+newSecretReader (SecretReaderConfig path) logger =+ SecretReader+ { readSecret = do+ exists <- doesFileExist (toS path)+ if exists+ then Just . decodeUtf8 <$> BS8.readFile (toS path)+ else error logger ("file does not exist at " <> path) $> Nothing+ } -data Console m = Console {- write :: Text -> m ()-, read :: m Text-}+data Console m = Console+ { write :: Text -> m (),+ read :: m Text+ } newConsole :: Console IO newConsole = Console putStrLn (toS <$> getLine)
test/Test/Tutorial/Exercise1.hs view
@@ -1,17 +1,17 @@ module Test.Tutorial.Exercise1 where -import Test.Tutorial.Application+import Test.Tutorial.Application newApp :: App newApp =- let logger' = newLogger- console' = newConsole- userInput' = newUserInput console'- rng' = newRng logger'+ let logger' = newLogger+ console' = newConsole+ userInput' = newUserInput console'+ rng' = newRng logger' secretReader' = newSecretReader (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") logger'- in App {- userInput = userInput'- , console = console'- , rng = rng'- , secretReader = secretReader'- }+ in App+ { userInput = userInput',+ console = console',+ rng = rng',+ secretReader = secretReader'+ }
test/Test/Tutorial/Exercise2.hs view
@@ -3,18 +3,18 @@ module Test.Tutorial.Exercise2 where -import Test.Tutorial.Application-import Data.Registry+import Data.Registry+import Test.Tutorial.Application registry :: Registry _ _ registry =- fun App- <: fun newUserInput- <: fun newSecretReader- <: fun newRng- <: fun newConsole- <: fun newLogger- <: val (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt")+ fun App+ <: fun newUserInput+ <: fun newSecretReader+ <: fun newRng+ <: fun newConsole+ <: fun newLogger+ <: val (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") newApp :: App newApp = make @App registry
test/Test/Tutorial/Exercise3.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Test.Tutorial.Exercise3 where -import Data.Registry-import Protolude-import Test.Tutorial.Application-import Test.Tutorial.Exercise2+import Data.Registry+import Protolude+import Test.Tutorial.Application+import Test.Tutorial.Exercise2 silentLogger :: Logger IO silentLogger = Logger (const (pure ())) (const (pure ()))@@ -24,6 +24,7 @@ newMisconfiguredSilentApp = make @App (val (SecretReaderConfig "missing") <: silentRegistry) newMisconfiguredRngSilentApp :: App-newMisconfiguredRngSilentApp = make @App $- specialize @(Rng IO) silentLogger $- val (SecretReaderConfig "missing") <: registry+newMisconfiguredRngSilentApp =+ make @App $+ specialize @(Rng IO) silentLogger $+ val (SecretReaderConfig "missing") <: registry
test/Test/Tutorial/Exercise4.hs view
@@ -1,16 +1,19 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Test.Tutorial.Exercise4 where -import Data.Registry-import Protolude-import Test.Tutorial.Application-import Test.Tutorial.Exercise2-import Test.Tutorial.Exercise3+import Data.Registry+import Protolude+import Test.Tutorial.Application+import Test.Tutorial.Exercise2+import Test.Tutorial.Exercise3 printApp :: IO ()-printApp = putStrLn $ unDot $ makeDot @App $- specialize @(Rng IO) silentLogger $- val (SecretReaderConfig "missing") <: registry+printApp =+ putStrLn $+ unDot $+ makeDot @App $+ specialize @(Rng IO) silentLogger $+ val (SecretReaderConfig "missing") <: registry
test/Test/Tutorial/Exercise5.hs view
@@ -1,38 +1,38 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Test.Tutorial.Exercise5 where -import qualified Data.ByteString.Char8 as BS8-import Data.Registry-import Protolude-import System.Directory (doesFileExist)-import Test.Tutorial.Application+import qualified Data.ByteString.Char8 as BS8+import Data.Registry+import Protolude+import System.Directory (doesFileExist)+import Test.Tutorial.Application newCheckedSecretReader :: SecretReaderConfig -> Logger IO -> IO (SecretReader IO) newCheckedSecretReader (SecretReaderConfig path) logger = do exists <- doesFileExist (toS path) if not exists then fileDoesNotExist else pure ()- pure SecretReader {- readSecret =- if exists then Just . decodeUtf8 <$> BS8.readFile (toS path)- else fileDoesNotExist $> Nothing- }-+ pure+ SecretReader+ { readSecret =+ if exists+ then Just . decodeUtf8 <$> BS8.readFile (toS path)+ else fileDoesNotExist $> Nothing+ } where fileDoesNotExist = error logger ("file does not exist at " <> path) - registryIO :: Registry _ _ registryIO =- funTo @IO App- <: funTo @IO newUserInput- <: funTo @IO newRng- <: funTo @IO newCheckedSecretReader- <: funTo @IO newLogger- <: funTo @IO newConsole- <: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt")+ funTo @IO App+ <: funTo @IO newUserInput+ <: funTo @IO newRng+ <: funTo @IO newCheckedSecretReader+ <: funTo @IO newLogger+ <: funTo @IO newConsole+ <: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") newAppIO :: IO App newAppIO = make @(IO App) registryIO
test/Test/Tutorial/Exercise6.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Test.Tutorial.Exercise6 where -import Data.Registry-import Protolude-import System.Directory (doesFileExist)-import Test.Tutorial.Application+import Data.Registry+import Protolude+import System.Directory (doesFileExist)+import Test.Tutorial.Application newCheckedSecretReader :: SecretReaderConfig -> Logger IO -> Tag "unchecked" (SecretReader IO) -> IO (SecretReader IO) newCheckedSecretReader (SecretReaderConfig path) logger uncheckedReader = do@@ -19,14 +19,14 @@ registryIO :: Registry _ _ registryIO =- funTo @IO App- <: funTo @IO newUserInput- <: funTo @IO newCheckedSecretReader- <: funTo @IO (tag @"unchecked" newSecretReader)- <: funTo @IO newRng- <: funTo @IO newLogger- <: funTo @IO newConsole- <: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt")+ funTo @IO App+ <: funTo @IO newUserInput+ <: funTo @IO newCheckedSecretReader+ <: funTo @IO (tag @"unchecked" newSecretReader)+ <: funTo @IO newRng+ <: funTo @IO newLogger+ <: funTo @IO newConsole+ <: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") newAppIO :: IO App newAppIO = make @(IO App) registryIO
test/Test/Tutorial/Exercise7.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Test.Tutorial.Exercise7 where -import Data.Registry-import Protolude-import Test.Tutorial.Application-import Test.Tutorial.Exercise6+import Data.Registry+import Protolude+import Test.Tutorial.Application+import Test.Tutorial.Exercise6 newInitializedLogger :: IO (Logger IO) newInitializedLogger = do@@ -24,10 +24,10 @@ memoizedRegistry = memoize @IO @(Logger IO) newInitializedRegistry newInitializedMemoizedAppIO :: IO App-newInitializedMemoizedAppIO = make @(IO App) =<< memoizedRegistry+newInitializedMemoizedAppIO = make @(IO App) =<< memoizedRegistry memoizedAllRegistry :: IO (Registry _ _) memoizedAllRegistry = memoizeAll @IO newInitializedRegistry newInitializedMemoizedAllAppIO :: IO App-newInitializedMemoizedAllAppIO = make @(IO App) =<< memoizedAllRegistry+newInitializedMemoizedAllAppIO = make @(IO App) =<< memoizedAllRegistry
test/Test/Tutorial/Exercise8.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Test.Tutorial.Exercise8 where -import Data.Registry-import Test.Tutorial.Application-import Test.Tutorial.Exercise2+import Data.Registry+import Test.Tutorial.Application+import Test.Tutorial.Exercise2 erasedRegistry :: Registry '[ERASED_TYPES] '[ERASED_TYPES] erasedRegistry = eraseTypes registry
test/test.hs view
@@ -1,5 +1,5 @@-import AutoDiscoveredSpecs (tests)-import Protolude-import Test.Tasty.Extensions+import AutoDiscoveredSpecs (tests)+import Protolude+import Test.Tasty.Extensions main = tests >>= defaultMain . groupByModuleName