cauldron 0.6.0.0 → 0.6.1.0

raw patch · 7 files changed

+368/−19 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +3/−2
• cauldron.cabal +2/−1
• lib/Cauldron.hs +15/−5
• lib/Cauldron/Builder.hs +264/−0
• test/codecTests.hs +62/−10
• test/tests.hs +17/−1

@@ -1,5 +1,10 @@ # Revision history for cauldron +## 0.6.1.0++* `ioEff` added to `Cauldron`.+* New module `Cauldron.Builder`.+ ## 0.6.0.0  * Remove sop-core dependency, incorporate just the needed functionality into the library.

@@ -22,8 +22,9 @@  To be honest, you probably shouldn't use this library. I have noticed that using **cauldron** is actually *more* verbose that manually doing the wiring yourself.-Perhaps it would start to pay for complex beans with many dependencies, but-I'm not sure.+Perhaps it would start to pay for complex beans with many dependencies, but I'm+not sure. See [here](https://hachyderm.io/@DiazCarrete/113732149622045046) for a+comparison of cauldron vs. manual in wiring a not-completely trivial app.  Another possible objection to this library is that wiring errors are detected at runtime. I don't find that to be a problem though: the wiring happens at the

@@ -1,6 +1,6 @@ cabal-version:      3.4 name:               cauldron-version:            0.6.0.0+version:            0.6.1.0 synopsis:           Dependency injection library description:        Dependency injection library that wires things at runtime. license:            BSD-3-Clause@@ -49,6 +49,7 @@         Cauldron.Beans         Cauldron.Args         Cauldron.Managed+        Cauldron.Builder  executable cauldron-example-wiring     import:           common-base

@@ -93,7 +93,9 @@     val,     val',     eff_,+    ioEff_,     eff,+    ioEff,     eff',     wire,     getConstructorArgs,@@ -153,6 +155,7 @@ import Cauldron.Beans qualified import Control.Exception (Exception (..)) import Control.Monad.Fix+import Control.Monad.IO.Class import Data.Bifunctor (first) import Data.ByteString qualified import Data.Dynamic@@ -836,8 +839,7 @@  -- | Sometimes the 'cook'ing process goes wrong. data RecipeError-  = -- | The 'Cauldron' identified by 'PathToCauldron' has beans-    -- that depend on beans that can't be found either in the current 'Cauldron' or its ancestors.+  = -- | A 'Constructor' depends on beans that can't be found either in the current 'Cauldron' or its ancestors.     MissingDependenciesError MissingDependencies   | -- | Beans that work both as primary beans and as secondary beans     -- are disallowed.@@ -1040,7 +1042,7 @@ val x = withFrozenCallStack (val' $ fmap runIdentity $ register $ fmap Identity x)  -- | Like 'val', but uses an alternative form of registering secondary beans.--- Less 'Registrable' typeclass magic, but more verbose.+-- Less 'Registrable' typeclass magic, but more verbose. Likely not what you want. val' :: forall bean m. (Applicative m, HasCallStack) => Args (Regs bean) -> Constructor m bean val' x = Constructor callStack $ fmap pure x @@ -1051,6 +1053,10 @@ eff_ :: forall bean m. (Functor m, HasCallStack) => Args (m bean) -> Constructor m bean eff_ x = Constructor callStack $ fmap (fmap pure) x +-- | Like 'eff_', but lifts 'IO' constructor effects into a general 'MonadIO'.+ioEff_ :: forall bean m. (MonadIO m, HasCallStack) => Args (IO bean) -> Constructor m bean+ioEff_ args = withFrozenCallStack (hoistConstructor liftIO (eff_ args))+ -- | Like 'eff_', but examines the @nested@ value produced by the action -- returned by the 'Args' looking for (potentially nested) tuples.  All tuple -- components except the rightmost-innermost one are registered as secondary@@ -1058,8 +1064,12 @@ eff :: forall {nested} bean m. (Registrable nested bean, Monad m, HasCallStack) => Args (m nested) -> Constructor m bean eff x = withFrozenCallStack (eff' $ register x) +-- | Like 'eff', but lifts 'IO' constructor effects into a general 'MonadIO'.+ioEff :: forall {nested} bean m. (Registrable nested bean, MonadIO m, HasCallStack) => Args (IO nested) -> Constructor m bean+ioEff args = withFrozenCallStack (hoistConstructor liftIO (eff args))+ -- | Like 'eff', but uses an alternative form of registering secondary beans.--- Less 'Registrable' typeclass magic, but more verbose.+-- Less 'Registrable' typeclass magic, but more verbose. Likely not what you want. eff' :: forall bean m. (HasCallStack) => Args (m (Regs bean)) -> Constructor m bean eff' = Constructor callStack @@ -1115,7 +1125,7 @@ -- -- 'Constructor's can produce, besides their \"primary\" bean result, -- \"secondary\" beans that are not reflected in the 'Constructor' signature.--- Multiple constructors across different recipeMap can produce secondary beans of the+-- Multiple constructors across different 'Recipe's can produce secondary beans of the -- same type. -- -- Secondary beans are a bit special, in that:

@@ -0,0 +1,264 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module is not required to use 'Cauldron's, but it provides a 'Builder' monad which lets you+-- define them in a manner which more closely resembles the syntax of wiring things \"manually\" in 'IO' or 'Managed'.+--+-- >>> :{+-- data Foo+--   = EndFoo+--   | FooToBar Bar+--   deriving stock (Show)+-- --+-- data Bar+--   = EndBar+--   | BarToFoo Foo+--   deriving stock (Show)+-- --+-- newtype Serializer a = Serializer {runSerializer :: a -> String}+-- --+-- makeFooSerializer :: Serializer Bar -> Serializer Foo+-- makeFooSerializer Serializer {runSerializer = runBar} =+--   Serializer+--     { runSerializer = \case+--         EndFoo -> ".EndFoo"+--         FooToBar bar -> ".FooToBar" ++ runBar bar+--     }+-- --+-- makeBarSerializer :: Serializer Foo -> Serializer Bar+-- makeBarSerializer Serializer {runSerializer = runFoo} =+--   Serializer+--     { runSerializer = \case+--         EndBar -> ".EndBar"+--         BarToFoo foo -> ".BarToFoo" ++ runFoo foo+--     }+-- --+-- builder :: Builder Identity ()+-- builder = mdo+--   foo <- _val_ $ makeFooSerializer <$> bar+--   bar <- _val_ $ makeBarSerializer <$> foo+--   pure ()+-- --+-- cauldron :: Either DuplicateBeans (Cauldron Identity)+-- cauldron = execBuilder builder+-- :}+--+-- Note that in the 'Builder' monad the values that we bind with @<-@ when using+-- functions like 'add', '_val_', or '_eff_' are really 'Args' values which+-- merely carry type information. We can dispense with them and use 'arg' or+-- 'wire' instead:+--+-- >>> :{+-- builder2 :: Builder Identity ()+-- builder2 = mdo+--   _ <- add $ val_ $ makeFooSerializer <$> arg+--   _ <- _val_ $ wire makeBarSerializer+--   pure ()+-- :}+module Cauldron.Builder+  ( Builder,+    add,+    execBuilder,++    -- * Two beans of the same type are forbidden+    DuplicateBeans (..),+    prettyDuplicateBeans,+    prettyDuplicateBeansLines,++    -- * Being polymorphic on the wiring monad+    MonadWiring (..),+    _ioEff_,+  )+where++import Cauldron+import Cauldron.Args+import Cauldron.Managed+import Control.Exception (Exception (..))+import Control.Monad.Fix+import Control.Monad.IO.Class+import Data.Dynamic+import Data.Foldable qualified+import Data.Function ((&))+import Data.Functor.Identity+import Data.Kind+import Data.List qualified+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Sequence (Seq)+import Data.Sequence qualified+import Data.Typeable+import GHC.Exception (CallStack, prettyCallStackLines)+import GHC.Stack (HasCallStack, callStack, withFrozenCallStack)++data Builder m a = Builder (Cauldron m) (Map TypeRep (Seq CallStack)) a+  deriving stock (Functor)++combineCallStackMaps :: Map TypeRep (Seq CallStack) -> Map TypeRep (Seq CallStack) -> Map TypeRep (Seq CallStack)+combineCallStackMaps = Map.unionWith (Data.Sequence.><)++instance Applicative (Builder m) where+  pure a = Builder Cauldron.empty Map.empty a+  Builder c1 m1 f <*> Builder c2 m2 a2 =+    Builder (c1 <> c2) (combineCallStackMaps m1 m2) (f a2)++instance Monad (Builder m) where+  (Builder c1 m1 a) >>= k =+    let Builder c2 m2 r = k a+     in Builder (c1 <> c2) (combineCallStackMaps m1 m2) r++instance MonadFix (Builder m) where+  mfix f =+    let b = f a+        ~(Builder _ _ a) = b+     in b++execBuilder :: Builder m a -> Either DuplicateBeans (Cauldron m)+execBuilder (Builder c m _) =+  let beanDefinitions =+        m+          & Map.mapMaybe \case+            c1 Data.Sequence.:<| c2 Data.Sequence.:<| rest -> Just (c1, c2, Data.Foldable.toList rest)+            _ -> Nothing+   in if (not $ Data.Foldable.null beanDefinitions)+        then Left $ DuplicateBeans beanDefinitions+        else Right c++-- | Because cauldron inject dependencies based on their types, a do-notation block which+-- binds two or more values of the same type would be ambiguous.+--+-- >>> :{+-- builderOops :: Builder Identity ()+-- builderOops = do+--   foo1 <- _val_ $ pure (5 :: Int)+--   foo2 <- _val_ $ pure (6 :: Int)+--   pure ()+-- :}+--+-- >>> :{+-- case execBuilder builderOops of+--    Left (DuplicateBeans _) -> "this should be the result"+--    Right _ -> "won't happen"+-- :}+-- "this should be the result"+data DuplicateBeans = DuplicateBeans (Map TypeRep (CallStack, CallStack, [CallStack]))+  deriving stock (Show)++instance Exception DuplicateBeans where+  displayException = prettyDuplicateBeans++prettyDuplicateBeans :: DuplicateBeans -> String+prettyDuplicateBeans = Data.List.intercalate "\n" . prettyDuplicateBeansLines++prettyDuplicateBeansLines :: DuplicateBeans -> [String]+prettyDuplicateBeansLines (DuplicateBeans beanMap) =+  [ "Some bean types defined more than once in builder:"+  ]+    ++ ( beanMap & Map.foldMapWithKey \rep (c1, c2, rest) ->+           ( [ "- Bean type " ++ show rep ++ " was defined in these locations:"+             ]+               ++ ( (c1 : c2 : rest) & foldMap \location ->+                      (("\t" ++) <$> prettyCallStackLines location)+                  )+           )+       )++-- | Add a 'Recipe' to the 'Cauldron' that is being built.+add ::+  forall {recipelike} {m} (bean :: Type).+  (Typeable bean, ToRecipe recipelike, HasCallStack) =>+  -- | A 'Recipe' or a 'Constructor'.+  recipelike m bean ->+  Builder m (Args bean)+add recipelike =+  Builder+    (Cauldron.empty & Cauldron.insert recipelike)+    (Map.singleton (typeRep (Proxy @bean)) (Data.Sequence.singleton callStack))+    (arg @bean)++-- | This class allows you to define polymorphic \"wirings\" which can work in+-- the 'Builder' monad to produce 'Cauldron's, but also wire beans directly in+-- 'IO' or 'Managed'.+--+-- If we limit ourselves exclusively to the methods of this class, it's not+-- possible to define decorators or secondary beans.+--+-- This class can help migrating from \"direct\"-style wirings to 'Cauldron's.+--+-- >>> :{+-- data A = A deriving Show+-- data B = B deriving Show+-- data C = C deriving Show+-- makeA :: A+-- makeA = A+-- makeB :: A -> B+-- makeB = \_ -> B+-- makeC :: A -> B -> IO C+-- makeC = \_ _ -> pure C+-- instantiations :: (Builder IO (Args C), IO (Identity C))+-- instantiations =+--    let polymorphicWiring = do+--           a <- _val_ $ pure makeA+--           b <- _val_ $ makeB <$> a+--           c <- _ioEff_ $ makeC <$> a <*> b+--           pure c+--     in (polymorphicWiring, polymorphicWiring)+-- :}+class (Monad m, Applicative (ArgsApplicative m), Monad (ConstructorMonad m)) => MonadWiring m where+  -- | Wraps every bean type that we bind using methods of this class.+  -- Will be 'Args' for 'Builder', but simply 'Identity' for 'IO' and 'Managed'.+  type ArgsApplicative m :: Type -> Type++  -- | The monad in which constructors have effects.+  type ConstructorMonad m :: Type -> Type++  _val_ :: (Typeable bean, HasCallStack) => ArgsApplicative m bean -> m (ArgsApplicative m bean)+  _eff_ :: (Typeable bean, HasCallStack) => ArgsApplicative m (ConstructorMonad m bean) -> m (ArgsApplicative m bean)++-- | Like '_eff_', but lifts 'IO' constructor effects into a general 'MonadIO'.+_ioEff_ ::+  (MonadWiring m, MonadIO (ConstructorMonad m), Typeable bean, HasCallStack) =>+  ArgsApplicative m (IO bean) ->+  m (ArgsApplicative m bean)+_ioEff_ args = withFrozenCallStack $ _eff_ $ liftIO <$> args++instance (Monad m) => MonadWiring (Builder m) where+  type ArgsApplicative (Builder m) = Args+  type ConstructorMonad (Builder m) = m+  _val_ :: (Typeable bean, HasCallStack) => Args bean -> Builder m (Args bean)+  _val_ v = withFrozenCallStack $ add (val_ v)+  _eff_ :: (Typeable bean, HasCallStack) => Args (m bean) -> Builder m (Args bean)+  _eff_ action = withFrozenCallStack $ add (eff_ action)++instance MonadWiring IO where+  type ArgsApplicative IO = Identity+  type ConstructorMonad IO = IO+  _val_ :: Identity bean -> IO (Identity bean)+  _val_ = pure+  _eff_ :: Identity (IO bean) -> IO (Identity bean)+  _eff_ = sequence++instance MonadWiring Managed where+  type ArgsApplicative Managed = Identity+  type ConstructorMonad Managed = Managed+  _val_ :: Identity a -> Managed (Identity a)+  _val_ = pure+  _eff_ :: Identity (Managed a) -> Managed (Identity a)+  _eff_ = sequence++-- $setup+-- >>> :set -XBlockArguments+-- >>> :set -XOverloadedLists+-- >>> :set -XLambdaCase+-- >>> :set -XRecursiveDo+-- >>> :set -XDerivingStrategies+-- >>> :set -Wno-incomplete-uni-patterns+-- >>> import Data.Functor.Identity+-- >>> import Data.Function ((&))+-- >>> import Data.Monoid+-- >>> import Data.Either (either)+-- >>> import Control.Exception (throwIO)

@@ -5,12 +5,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE NoFieldSelectors #-}  module Main (main) where  import Cauldron+import Cauldron.Builder+import Control.Exception (throwIO) import Data.Foldable qualified+import Data.Function ((&)) import Data.Functor.Identity import Data.Monoid import Test.Tasty@@ -67,6 +71,36 @@       recipe @(Serializer Baz) $ val $ wire makeBazSerializer     ] +builder :: Builder Identity ()+builder = mdo+  foo <- _val_ $ makeFooSerializer <$> bar+  bar <- _val_ $ makeBarSerializer <$> foo <*> baz+  baz <- _val_ $ makeBazSerializer <$> foo+  pure ()++builder2 :: Builder Identity ()+builder2 = mdo+  _ <- _val_ $ wire makeFooSerializer+  _ <- _val_ $ wire makeBarSerializer+  _ <- _val_ $ wire makeBazSerializer+  pure ()++builder3 :: Builder Identity ()+builder3 = mdo+  foo <- add $ val_ $ wire makeFooSerializer+  _ <- add $ val_ $ makeBarSerializer <$> foo <*> baz+  baz <- add $ val_ $ wire makeBazSerializer+  pure ()++builderDupErr :: Builder Identity ()+builderDupErr = mdo+  foo1 <- _val_ $ makeFooSerializer <$> bar+  foo2 <- _val_ $ makeFooSerializer <$> bar+  bar <- _val_ $ makeBarSerializer <$> foo1 <*> baz+  baz <- _val_ $ makeBazSerializer <$> foo2+  _ <- _val_ $ makeBazSerializer <$> foo2+  pure ()+ newtype Acc = Acc Int   deriving stock (Show)   deriving stock (Eq)@@ -113,17 +147,22 @@ tests =   testGroup     "All"-    [ testCase "successful cyclic wiring" do-        case cook allowDepCycles cauldron of+    [ testCase "successful cyclic wiring" do makeBasicTest cauldron,+      testCase "successful cyclic wiring - builder" do+        c <- builder & execBuilder & either throwIO pure+        makeBasicTest c,+      testCase "successful cyclic wiring - builder 2" do+        c <- builder2 & execBuilder & either throwIO pure+        makeBasicTest c,+      testCase "successful cyclic wiring - builder 3" do+        c <- builder3 & execBuilder & either throwIO pure+        makeBasicTest c,+      testCase "should fail builder exec" do+        builderDupErr & execBuilder & \case           Left _ -> do-            -- putStrLn $ prettyRecipeError err-            assertFailure "could not wire"-          Right (Identity bs) ->-            case taste bs of-              Nothing -> assertFailure "serializer not found"-              Just (Serializer {runSerializer}) -> do-                let value = FooToBar (BarToFoo (FooToBar (BarToBaz EndBaz)))-                assertEqual "experted result" ".FooToBar.BarToFoo.FooToBar.BarToBar.EndBaz" (runSerializer value),+            -- appendFile "/tmp/foo.txt" $ prettyDuplicateBeans err+            pure ()+          Right _ -> assertFailure "Builder should have failed with duplicate beans error",       testCase "should fail cycle wiring" do         Data.Foldable.for_ @[] [("forbid", forbidDepCycles), ("selfdeps", allowSelfDeps)] \(name, fire) ->           case cook fire cauldron of@@ -156,6 +195,19 @@               Left _ -> assertFailure $ "Unexpected error when wiring" ++ name               Right _ -> assertFailure $ "Unexpected success when wiring" ++ name     ]+  where+    makeBasicTest :: Cauldron Identity -> IO ()+    makeBasicTest theCauldron =+      case cook allowDepCycles theCauldron of+        Left _ -> do+          -- putStrLn $ prettyRecipeError err+          assertFailure "could not wire"+        Right (Identity bs) ->+          case taste bs of+            Nothing -> assertFailure "serializer not found"+            Just (Serializer {runSerializer}) -> do+              let value = FooToBar (BarToFoo (FooToBar (BarToBaz EndBaz)))+              assertEqual "experted result" ".FooToBar.BarToFoo.FooToBar.BarToBar.EndBaz" (runSerializer value)  main :: IO () main = defaultMain tests

@@ -163,6 +163,17 @@         ]     ] +cauldronNonEmptyWrongOrder :: NonEmpty (Cauldron M)+cauldronNonEmptyWrongOrder = do+  Data.List.NonEmpty.fromList+    [ fromRecipeList+        [ recipe @(Weird M) $ eff $ wire makeWeird+        ],+      fromRecipeList+        [ recipe @(Logger M) $ eff $ pure makeLogger+        ]+    ]+ cauldronLonely :: Cauldron M cauldronLonely =   fromRecipeList@@ -257,13 +268,18 @@               assertFailure "cauldron 2 has the bare undecorated logger from cauldron 1 in its dep graph, despite not depending on it directly"             pure ()           _ -> assertFailure "should never happen, malformed test",+      testCase "value sequential - parents can't see beans in children" do+        case cookNonEmpty' cauldronNonEmptyWrongOrder of+          Left (MissingDependenciesError _) -> pure ()+          Left _ -> assertFailure "Unexpected error"+          Right _ -> assertFailure "parent cauldron sees bean in child cauldron",       testCase "tree of cauldrons" do         case cookTree' treeOfCauldrons of           Left err -> assertFailure $ "failed to build tree: " ++ show err           Right (Identity beans) -> case beans of             Node bbase [Node bbranch1 [], Node bbranch2 []] ->               assertEqual-                "expected accs across brances"+                "expected accs across branches"                 (Just (Sum 1), Just (Sum 8), Just (Sum 12))                 (taste @(Sum Int) bbase, taste @(Sum Int) bbranch1, taste @(Sum Int) bbranch2)             _ -> assertFailure $ "tree has unexpected shape",