diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/cauldron.cabal b/cauldron.cabal --- a/cauldron.cabal +++ b/cauldron.cabal @@ -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 diff --git a/lib/Cauldron.hs b/lib/Cauldron.hs --- a/lib/Cauldron.hs +++ b/lib/Cauldron.hs @@ -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: diff --git a/lib/Cauldron/Builder.hs b/lib/Cauldron/Builder.hs new file mode 100644 --- /dev/null +++ b/lib/Cauldron/Builder.hs @@ -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) diff --git a/test/codecTests.hs b/test/codecTests.hs --- a/test/codecTests.hs +++ b/test/codecTests.hs @@ -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 diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -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",