registry 0.1.9.1 → 0.1.9.3
raw patch · 19 files changed
+181/−159 lines, 19 files
Files
- registry.cabal +3/−3
- src/Data/Registry/Internal/Make.hs +1/−1
- src/Data/Registry/Lift.hs +14/−0
- src/Data/Registry/Registry.hs +12/−7
- test/Test/Data/Registry/GenSpec.hs +14/−15
- test/Test/Data/Registry/Internal/GensRegistry.hs +31/−32
- test/Test/Data/Registry/Make/MakeSpec.hs +4/−4
- test/Test/Data/Registry/Make/MemoizeSpec.hs +9/−10
- test/Test/Data/Registry/Make/SpecializationSpec.hs +22/−26
- test/Test/Data/Registry/Make/TweakingSpec.hs +6/−6
- test/Test/Data/Registry/MonadRandomSpec.hs +1/−2
- test/Test/Data/Registry/RegistrySpec.hs +22/−1
- test/Test/Data/Registry/SimpleExamples.hs +11/−15
- test/Test/Data/Registry/SmallExample.hs +6/−8
- test/Test/Data/Registry/THSpec.hs +2/−2
- test/Test/Data/Registry/WarmupSpec.hs +4/−5
- test/Test/Tutorial/Exercise2.hs +6/−7
- test/Test/Tutorial/Exercise5.hs +6/−7
- test/Test/Tutorial/Exercise6.hs +7/−8
registry.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 2d9c064c60106be14a1e61ac45b2d6250d4a76f9b3b436402edf91e00e107f04+-- hash: a119d8aff497400e50a6bd878674be085b5225c5ab510f7ced5b47549ee2b895 name: registry-version: 0.1.9.1+version: 0.1.9.3 synopsis: data structure for assembling components description: This library provides a "Registry" which is a data structure containing a list of functions and values representing dependencies in a directed acyclic graph. A `make` function can then be used to create a value of a specific type out of the registry. You can start with the [README](https://github.com/etorreborre/registry/blob/master/README.md) for a full description of the library.
src/Data/Registry/Internal/Make.hs view
@@ -63,7 +63,7 @@ missingInputTypes = inputTypes L.\\ madeInputTypes in lift $ Left $- unlines+ T.unlines $ ["could not make all the inputs for ", show (funDescription function), ". Only "] <> (show <$> inputs) <> ["could be made. Missing"]
src/Data/Registry/Lift.hs view
@@ -39,6 +39,20 @@ allTo :: forall f a b. ApplyVariadic f a b => a -> b allTo a = (applyVariadic :: f a -> b) (pure a) +-- | Typeclass for lifting impure functions to effectful arguments and results+class Monad f => ApplyVariadic1 f a b where+ applyVariadic1 :: f a -> b++instance (Monad f, b ~ f a) => ApplyVariadic1 f (f a) b where+ applyVariadic1 = join++instance (Monad f, ApplyVariadic1 f a' b', b ~ (f a -> b')) => ApplyVariadic1 f (a -> a') b where+ applyVariadic1 f fa = applyVariadic1 (f <*> fa)++-- | Lift an effectful function to effectful arguments and results+argsTo :: forall f a b . ApplyVariadic1 f a b => a -> b+argsTo a = (applyVariadic1 :: f a -> b) (pure a)+ -- | Typeclass for lifting a function with a result of type m b into a function -- with a result of type n b class ApplyVariadic2 f g a b where
src/Data/Registry/Registry.hs view
@@ -15,14 +15,13 @@ * specializations: description of specific values to use while trying to build another value of a given type * modifiers: function to apply to a newly built value before storing it for future use - A registry is created by using the `+:` operator, adding functions or values to the empty `end` registry:+ The `<:` operator, to append functions or values to a registry: > registry = > val (Config 1)- > +: val "hello"- > +: fun add1- > +: fun show1- > +: end+ > <: 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 allow some checks to be made when we want to build a value out of the registry.@@ -31,8 +30,7 @@ > mocks = > fun noLogging- > +: fun inMemoryDb- > +: end+ > <: fun inMemoryDb > > mocks <+> registry @@ -164,6 +162,13 @@ -- to an 'Applicative' context funTo :: forall m a b . (ApplyVariadic m a b, Typeable a, Typeable b) => a -> Typed b funTo a = fun (allTo @m a)++-- | This is a shortcut to @fun . argsTo@ where @allTo@ lifts 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 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
test/Test/Data/Registry/GenSpec.hs view
@@ -76,17 +76,16 @@ -- | Create a registry for all generators registry = funTo @Gen Company- +: funTo @Gen Department- +: funTo @Gen Employee- +: funTo @Gen Fixed- +: funTo @Gen Name- +: funTo @Gen Age- +: fun (genList @Department)- +: fun (genList @Employee)- +: fun genInt- +: fun genText- +: fun genDouble- +: end+ <: funTo @Gen Department+ <: funTo @Gen Employee+ <: funTo @Gen Fixed+ <: funTo @Gen Name+ <: funTo @Gen Age+ <: fun (genList @Department)+ <: fun (genList @Employee)+ <: fun genInt+ <: fun genText+ <: fun genDouble test_company_with_one_employee = noShrink $ prop "generate just one employee" $ runR $ do setMinimalCompany@@ -99,10 +98,10 @@ registry' = fun (sequence . replicate @(Gen Salary) 100)- +: fun salaryGen- +: funTo @Gen (tag @"Fixed" Fixed)- +: funTo @Gen (tag @"Variable" Variable)- +: registry+ <: 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/Test/Data/Registry/Internal/GensRegistry.hs view
@@ -18,38 +18,37 @@ -- Hedgehog generators for the internal types gensRegistry = funTo @Gen UntypedRegistry- +: funTo @Gen Values- +: funTo @Gen Functions- +: fun genModifierFunction- +: funTo @Gen Specializations- +: funTo @Gen Modifiers- +: funTo @Gen Context- +: funTo @Gen Function- +: funTo @Gen ProvidedValue- +: funTo @Gen ValueDescription- +: funTo @Gen FunctionDescription- +: funTo @Gen Specialization- +: fun (genNonEmpty @SomeTypeRep)- +: fun (genList @Specialization)- +: fun (genList @(SomeTypeRep, ModifierFunction))- +: fun (genPair @SomeTypeRep @ModifierFunction)- +: fun (genPair @(NonEmpty SomeTypeRep) @Value)- +: fun (genList @Function)- +: fun (genList @SomeTypeRep)- +: fun (genList @(SomeTypeRep, Maybe SomeTypeRep))- +: fun (genList @Value)- +: fun (genList @Function)- +: fun (genMaybe @Text)- +: fun (genMaybe @SomeTypeRep)- +: fun (genPair @SomeTypeRep @(Maybe SomeTypeRep))- +: fun (genList @Text)- +: fun genInt- +: fun genText- +: fun genTextToInt- +: fun genDynamic- +: fun genSomeTypeRep- +: end-+ <: funTo @Gen Values+ <: funTo @Gen Functions+ <: fun genModifierFunction+ <: funTo @Gen Specializations+ <: funTo @Gen Modifiers+ <: funTo @Gen Context+ <: funTo @Gen Function+ <: funTo @Gen ProvidedValue+ <: funTo @Gen ValueDescription+ <: funTo @Gen FunctionDescription+ <: funTo @Gen Specialization+ <: fun (genNonEmpty @SomeTypeRep)+ <: fun (genList @Specialization)+ <: fun (genList @(SomeTypeRep, ModifierFunction))+ <: fun (genPair @SomeTypeRep @ModifierFunction)+ <: fun (genPair @(NonEmpty SomeTypeRep) @Value)+ <: fun (genList @Function)+ <: fun (genList @SomeTypeRep)+ <: fun (genList @(SomeTypeRep, Maybe SomeTypeRep))+ <: fun (genList @Value)+ <: fun (genList @Function)+ <: fun (genMaybe @Text)+ <: fun (genMaybe @SomeTypeRep)+ <: fun (genPair @SomeTypeRep @(Maybe SomeTypeRep))+ <: fun (genList @Text)+ <: fun genInt+ <: fun genText+ <: fun genTextToInt+ <: fun genDynamic+ <: fun genSomeTypeRep+ -- * generators newtype TextToInt = TextToInt (Text -> Int) instance Show TextToInt where show _ = "<function>"
test/Test/Data/Registry/Make/MakeSpec.hs view
@@ -12,9 +12,9 @@ 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)- +: end+ <: valTo @IO (1::Int)+ <: valTo @IO ("hey"::Text)+ make @(IO F1) r f1 === F1 1 "hey"@@ -28,7 +28,7 @@ test_cycle = test "cycle can be detected" $ do -- a registry with 2 functions inverse of each other- let explosive = makeUnsafe @Text (fun add1 +: fun dda1 +: end)+ let explosive = makeUnsafe @Text (fun add1 <: fun dda1) r <- liftIO $ try (print explosive) case r of Left (_ :: SomeException) -> assert True
test/Test/Data/Registry/Make/MemoizeSpec.hs view
@@ -17,9 +17,9 @@ newSingOnce <- once (newSing counter) let r = funTo @IO newC1- +: funTo @IO newC2- +: funTo @IO newSingOnce- +: end+ <: funTo @IO newC2+ <: funTo @IO newSingOnce+ c1 <- make @(IO C1) r c2 <- make @(IO C2) r pure (c1, c2)@@ -33,9 +33,9 @@ counter <- newIORef 0 let r = funTo @IO newC1- +: funTo @IO newC2- +: funTo @IO (newSing counter)- +: end+ <: funTo @IO newC2+ <: funTo @IO (newSing counter)+ r' <- memoize @IO @Sing r c1 <- make @(IO C1) r' c2 <- make @(IO C2) r'@@ -66,10 +66,9 @@ messagesRef <- liftIO $ newIORef [] let registry = funTo @RIO App- +: funTo @RIO newA- +: funTo @RIO newB- +: fun (newC messagesRef)- +: end+ <: funTo @RIO newA+ <: funTo @RIO newB+ <: fun (newC messagesRef) -- just instantiate the app for its effects withRegistry @App registry $ \_ _ -> pure ()
test/Test/Data/Registry/Make/SpecializationSpec.hs view
@@ -15,9 +15,8 @@ test_specialization_1 = test "values can use other values depending on some context" $ do (c1, c2) <- liftIO $ do let r = val (Config 3)- +: fun newUseConfig1- +: fun newUseConfig2- +: end+ <: fun newUseConfig1+ <: fun newUseConfig2 let r' = specialize @UseConfig1 (Config 1) $ specialize @UseConfig2 (Config 2) r pure (printConfig1 (make @UseConfig1 r'), printConfig2 (make @UseConfig2 r'))@@ -30,9 +29,8 @@ test_specialization_2 = test "more specialized context" $ do c <- liftIO $ do let r = val (Config 3)- +: fun newUseConfig- +: fun newClient1- +: end+ <: fun newUseConfig+ <: fun newClient1 let r' = specialize @Client1 (Config 1) $ specialize @UseConfig (Config 2) r pure $ printClientConfig1 (make @Client1 r')@@ -46,11 +44,10 @@ test_specialization_3 = test "specialized values must be kept up to their start context" $ do (c1, c2) <- liftIO $ do let r = val (Config 3)- +: fun newUseConfig- +: fun newClient1- +: fun newClient2- +: fun newBase- +: end+ <: fun newUseConfig+ <: fun newClient1+ <: fun newClient2+ <: fun newBase let r' = specialize @Client1 (Config 1) $ specialize @Client2 (Config 2) r pure $ printBase (make @Base r')@@ -99,11 +96,11 @@ test_specialization_4 = test "values can be specialized for a given path" $ do (c1, c2, c3) <- liftIO $ do let r = valTo @RIO (Config 3)- +: funTo @RIO newUseConfig- +: funTo @RIO newClient1- +: funTo @RIO newClient2- +: funTo @RIO newBase2- +: end+ <: funTo @RIO newUseConfig+ <: funTo @RIO newClient1+ <: funTo @RIO newClient2+ <: funTo @RIO newBase2+ let r' = specializePathValTo @RIO @[RIO Base2, RIO Client1, RIO UseConfig] (Config 1) . specializeValTo @RIO @(RIO UseConfig) (Config 2) $ r @@ -229,19 +226,18 @@ aRegistryIO = memoizeAll @IO $ specializePathUnsafeValTo @IO @[IO ToOverride, IO InCommon] (SomeConfig "specialized config") $ valTo @IO (SomeConfig "default config")- +: funTo @IO newToKeepDefault- +: funTo @IO newToOverride- +: funTo @IO InCommon- +: funTo @IO SomeData- +: end+ <: funTo @IO newToKeepDefault+ <: funTo @IO newToOverride+ <: funTo @IO InCommon+ <: funTo @IO SomeData test_make_specialized_values = test "specialized values can be made" $ do let r = val (Config 3)- +: fun newUseConfig- +: fun newClient1- +: fun newClient2- +: fun newBase2- +: end+ <: fun newUseConfig+ <: fun newClient1+ <: fun newClient2+ <: fun newBase2+ let r' = specializePathVal @[Base2, Client1, UseConfig] (Config 1) . specializeVal @UseConfig (Config 2) $ r
test/Test/Data/Registry/Make/TweakingSpec.hs view
@@ -12,9 +12,9 @@ test_tweak = test "created values can be modified prior to being stored" $ do c1 <- liftIO $ do let r = val (Config 1)- +: fun newUseConfig1- +: fun newAppUsingConfig1- +: end+ <: fun newUseConfig1+ <: fun newAppUsingConfig1+ let r' = tweak (\(UseConfig1 _) -> UseConfig1 (Config 10)) r pure (printAppConfig (make @AppUsingConfig1 r')) @@ -33,9 +33,9 @@ test_tweak_non_lossy = test "a modified value must not lose its context, specialization or dependencies" $ do (a, stats) <- liftIO $ do let r = val (C 1)- +: fun B- +: fun A- +: end+ <: fun B+ <: fun A+ let r' = specialize @A @C (C 2) r let r'' = tweak (\(B (C _)) -> B (C 3)) r' pure (make @A r'', makeStatistics @A r'')
test/Test/Data/Registry/MonadRandomSpec.hs view
@@ -86,8 +86,7 @@ -- It uses the global StdGen registryProd = funTo @IO newClient- +: fun newRandomGenerator- +: end+ <: 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
test/Test/Data/Registry/RegistrySpec.hs view
@@ -41,7 +41,28 @@ registry1 :: Registry '[] '[Int, Text] registry1 = normalize $- (val (1::Int))+ 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 = outTo @RIO liftIO a++c :: RIO Int -> RIO Int -> RIO Int+c = allTo @RIO b++-- 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)++-- to avoid the issue with type inference above, we can use argsTo+e :: RIO Int -> RIO Int -> RIO Int+e = argsTo @RIO (outTo @RIO liftIO a)
test/Test/Data/Registry/SimpleExamples.hs view
@@ -43,10 +43,9 @@ registry1 :: Registry [Int, Text, Text1] [Int, Text, Text1, Text2] registry1 = normalize $ val int1- +: fun add1- +: fun add2- +: fun toText2- +: end+ <: fun add1+ <: fun add2+ <: fun toText2 countSize :: Text -> Maybe Int countSize t = Just (T.length t)@@ -69,9 +68,8 @@ registry2 :: Registry '[Int, Text] '[Int, Text, Int1] registry2 = fun int1- +: fun add1- +: fun countSize1- +: end+ <: fun add1+ <: fun countSize1 made4 :: Int1 made4 = make @Int1 registry2@@ -91,10 +89,9 @@ registry3 :: Registry [Double, Int, Text] [Int, Text1, Text, Int1] registry3 = val int1- +: fun unknown- +: fun add1- +: fun countSize1- +: end+ <: fun unknown+ <: fun add1+ <: fun countSize1 -- | This does not compile because we need a double -- to make Text1 and it is not in the list of outputs@@ -133,9 +130,8 @@ registryWithOptionalComponents = val InDev- +: fun newService- +: fun newProductionComponentBuilder- +: fun logging- +: end+ <: fun newService+ <: fun newProductionComponentBuilder+ <: fun logging makeService = make @Service registryWithOptionalComponents
test/Test/Data/Registry/SmallExample.hs view
@@ -46,8 +46,7 @@ newS3 :: MonadIO m => S3Config -> Logger -> m S3 newS3 config logger = pure $ S3 $- \t -> (logger & info) ("storing on S3 with config " <> P.show config) >>- void (print t) -- send the text to s3+ const $ info logger $ "storing on S3 with config " <> P.show config newtype Application = Application { run :: Text -> IO Int@@ -65,11 +64,10 @@ -- | Create a registry for all constructors registry = funTo @IO (newS3 @IO)- +: funTo @IO (newApplication @IO)- +: funTo @IO noLogging- +: funTo @IO newLinesCounter- +: valTo @IO (S3Config "bucket" "key")- +: end+ <: funTo @IO (newApplication @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@@ -80,5 +78,5 @@ test_create = test "create the application" $ do app <- liftIO createApplication -- nothing should crash!- r <- liftIO $ (app & run) "hello\nworld"+ r <- liftIO $ run app "hello\nworld" r === 2
test/Test/Data/Registry/THSpec.hs view
@@ -64,7 +64,7 @@ times2 n = show (n * 2) reg0 :: Registry '[Int] '[Text, Int, Int]-reg0 = fun add0 +: val (1::Int) +: val (2 :: Int) +: end+reg0 = fun add0 <: val (1::Int) <: val (2 :: Int) -- See the gory details of why this is necessary: https://gitlab.haskell.org/ghc/ghc/issues/9813 $(return [])@@ -88,7 +88,7 @@ addIO0 _ = pure "" regIO0 :: Registry '[IO Int] '[IO Text, IO Int, IO Int]-regIO0 = funTo @IO addIO0 +: valTo @IO (1 :: Int) +: valTo @IO (2 :: Int) +: end+regIO0 = funTo @IO addIO0 <: valTo @IO (1 :: Int) <: valTo @IO (2 :: Int) -- See the gory details of why this is necessary: https://gitlab.haskell.org/ghc/ghc/issues/9813 $(return [])
test/Test/Data/Registry/WarmupSpec.hs view
@@ -29,11 +29,10 @@ registry <- liftIO $ memoizeAll @RIO $ funTo @RIO App- +: funTo @RIO newA- +: funTo @RIO newB- +: fun (newC messagesRef)- +: end-+ <: funTo @RIO newA+ <: funTo @RIO newB+ <: fun (newC messagesRef)+ void $ withRIO (makeUnsafe @(RIO App) registry) $ const (pure ()) ms <- liftIO $ readIORef messagesRef
test/Test/Tutorial/Exercise2.hs view
@@ -10,13 +10,12 @@ registry :: Registry _ _ registry = fun App- +: fun newLogger- +: fun newConsole- +: fun newUserInput- +: fun newRng- +: fun newSecretReader- +: val (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt")- +: end+ <: fun newLogger+ <: fun newConsole+ <: fun newUserInput+ <: fun newRng+ <: fun newSecretReader+ <: val (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") newApp :: App newApp = make @App registry
test/Test/Tutorial/Exercise5.hs view
@@ -27,13 +27,12 @@ registryIO :: Registry _ _ registryIO = funTo @IO App- +: funTo @IO newLogger- +: funTo @IO newConsole- +: funTo @IO newUserInput- +: funTo @IO newRng- +: funTo @IO newCheckedSecretReader- +: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt")- +: end+ <: funTo @IO newLogger+ <: funTo @IO newConsole+ <: funTo @IO newUserInput+ <: funTo @IO newRng+ <: funTo @IO newCheckedSecretReader+ <: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") newAppIO :: IO App newAppIO = make @(IO App) registryIO
test/Test/Tutorial/Exercise6.hs view
@@ -20,14 +20,13 @@ registryIO :: Registry _ _ registryIO = funTo @IO App- +: funTo @IO newLogger- +: funTo @IO newConsole- +: funTo @IO newUserInput- +: funTo @IO newRng- +: funTo @IO newCheckedSecretReader- +: funTo @IO (tag @"unchecked" newSecretReader)- +: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt")- +: end+ <: funTo @IO newLogger+ <: funTo @IO newConsole+ <: funTo @IO newUserInput+ <: funTo @IO newRng+ <: funTo @IO newCheckedSecretReader+ <: funTo @IO (tag @"unchecked" newSecretReader)+ <: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") newAppIO :: IO App newAppIO = make @(IO App) registryIO