diff --git a/registry.cabal b/registry.cabal --- a/registry.cabal +++ b/registry.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: b2a9bd3b890c2e666f472cab045fa0e78cb9e7663a6fbbac1a2417d264d3b534 +-- hash: 27bccc93b2ea165fa0da09cc90d2c9392f38296f8240cebb4ac972dd05713611 name: registry -version: 0.1.6.1 +version: 0.1.6.2 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. diff --git a/src/Data/Registry/Internal/Make.hs b/src/Data/Registry/Internal/Make.hs --- a/src/Data/Registry/Internal/Make.hs +++ b/src/Data/Registry/Internal/Make.hs @@ -18,9 +18,10 @@ import Data.List hiding (unlines) import Data.Registry.Internal.Dynamic import Data.Registry.Internal.Registry -import Data.Registry.Internal.Types import Data.Registry.Internal.Stack +import Data.Registry.Internal.Types import Data.Text as T (unlines) +import qualified Data.Text as T import Protolude as P hiding (Constructor) import Type.Reflection @@ -48,11 +49,14 @@ Nothing -> -- if not, is there a way to build such value? case findConstructor targetType functions of - Nothing -> lift $ Left ("cannot find a constructor for " <> show targetType) + Nothing -> lift $ Left $ + "When trying to create the following values\n\n " + <> T.intercalate "\nrequiring " (showContextTargets context) + <> "\n\nNo constructor was found for " <> show targetType Just function -> do let inputTypes = collectInputTypes function - inputs <- makeInputs inputTypes context functions specializations modifiers + inputs <- makeInputs function inputTypes context functions specializations modifiers if length inputs /= length inputTypes then @@ -79,21 +83,33 @@ modified <- storeValue modifiers v pure (Just modified) + +-- | Show the target type and possibly the constructor function requiring it +-- 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) + -- | Make the input values of a given function -- When a value has been made it is placed on top of the -- existing registry so that it is memoized if needed in -- subsequent calls makeInputs :: - [SomeTypeRep] -- ^ input types to build + 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 -makeInputs [] _ _ _ _ = pure [] +makeInputs _ [] _ _ _ _ = pure [] -makeInputs (i : ins) (Context context) functions specializations modifiers = - if i `elem` context +makeInputs function (i : ins) c@(Context context) functions specializations modifiers = + if i `elem` (contextTypes c) then lift $ Left $ toS @@ -102,12 +118,12 @@ <> (show <$> context) <> ["But we are trying to build again " <> show i] else do - madeInput <- makeUntyped i (Context (i : context)) functions specializations modifiers + madeInput <- makeUntyped i (Context ((i, Just (funDynTypeRep function)) : context)) functions specializations modifiers case madeInput of Nothing -> -- if one input cannot be made, iterate with the rest for better reporting -- of what could be eventually made - makeInputs ins (Context context) functions specializations modifiers + makeInputs function ins (Context context) functions specializations modifiers Just v -> - (v :) <$> makeInputs ins (Context context) functions specializations modifiers + (v :) <$> makeInputs function ins (Context context) functions specializations modifiers diff --git a/src/Data/Registry/Internal/Types.hs b/src/Data/Registry/Internal/Types.hs --- a/src/Data/Registry/Internal/Types.hs +++ b/src/Data/Registry/Internal/Types.hs @@ -118,8 +118,8 @@ isInSpecializationContext :: SomeTypeRep -> Value -> Bool isInSpecializationContext target value = case specializationContext value of - Just (Context cs) -> target `elem` cs - Nothing -> False + Just context -> target `elem` (contextTypes context) + Nothing -> False -- | Return True if a value has transitives dependencies which are -- specialized values @@ -214,16 +214,29 @@ -- | The types of values that we are trying to build at a given moment -- of the resolution algorithm. +-- We also store the function requiring a given value type to provide +-- better error messages -- IMPORTANT: this is a *stack*, the deepest elements in the value -- graph are first in the list -newtype Context = Context { - _contextStack :: [SomeTypeRep] -} deriving (Eq, Hashable, Show, Semigroup, Monoid) +data Context = Context { + _contextStack :: [(SomeTypeRep, Maybe SomeTypeRep)] +} deriving (Eq, Show) +instance Semigroup Context where + Context c1 <> Context c2 = Context (c1 <> c2) + +instance Monoid Context where + mempty = Context mempty + mappend = (<>) + +-- | Return the target types for a given context +contextTypes :: Context -> [SomeTypeRep] +contextTypes (Context cs) = fmap fst cs + -- | The values that a value depends on newtype Dependencies = Dependencies { unDependencies :: [Value] -} deriving (Show, Hashable, Semigroup, Monoid) +} deriving (Show, Semigroup, Monoid) -- | The values types that a value depends on newtype DependenciesTypes = DependenciesTypes { @@ -284,8 +297,8 @@ -- | 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 contextPath) (Specialization specializationPath _) = - P.all (`elem` contextPath) specializationPath +isContextApplicable context (Specialization specializationPath _) = + P.all (`elem` (contextTypes context)) specializationPath -- | Return the specifications valid in a given context applicableTo :: Specializations -> Context -> Specializations @@ -299,10 +312,10 @@ -- the "deepest" in the current context -- If there is a tie we take the "highest" highest type of each specializedContext :: Context -> Specialization -> SpecializedContext -specializedContext (Context cs) specialization = +specializedContext context specialization = SpecializedContext - (specializationStart specialization `elemIndex` cs) - (specializationEnd specialization `elemIndex` cs) + (specializationStart 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 diff --git a/src/Data/Registry/Make.hs b/src/Data/Registry/Make.hs --- a/src/Data/Registry/Make.hs +++ b/src/Data/Registry/Make.hs @@ -59,7 +59,7 @@ -- | This version of make only execute checks at runtime -- this can speed-up compilation when writing tests or in ghci makeEither :: forall a ins out . (Typeable a) => Registry ins out -> Either Text a -makeEither = makeEitherWithContext (Context [someTypeRep (Proxy :: Proxy a)]) +makeEither = makeEitherWithContext (Context [(someTypeRep (Proxy :: Proxy a), Nothing)]) -- | This version of `make` only execute checks at runtime -- this can speed-up compilation when writing tests or in ghci @@ -103,11 +103,11 @@ -- | makeEither for specialized values makeSpecializedEither :: forall a b ins out . (Typeable a, Typeable b) => Registry ins out -> Either Text b -makeSpecializedEither = makeEitherWithContext (Context [someTypeRep (Proxy :: Proxy a), someTypeRep (Proxy :: Proxy b)]) +makeSpecializedEither = makeEitherWithContext (Context [(someTypeRep (Proxy :: Proxy a), Nothing), (someTypeRep (Proxy :: Proxy b), Nothing)]) -- | makeEither for specialized values makeSpecializedPathEither :: forall path b ins out . (PathToTypeReps path, Typeable b) => Registry ins out -> Either Text b -makeSpecializedPathEither = makeEitherWithContext (Context (toList $ someTypeReps (Proxy :: Proxy path))) +makeSpecializedPathEither = makeEitherWithContext (Context (fmap (\t -> (t, 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 @@ -127,12 +127,20 @@ of Left e -> - Left $ "could not create a " <> show targetType <> " out of the registry because " <> e <> "\nThe registry is\n" <> - show registry + 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" + Right Nothing -> - Left $ "could not create a " <> show targetType <> " out of the registry." <> "\nThe registry is\n" <> - show registry + 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)) diff --git a/src/Data/Registry/Registry.hs b/src/Data/Registry/Registry.hs --- a/src/Data/Registry/Registry.hs +++ b/src/Data/Registry/Registry.hs @@ -63,13 +63,21 @@ } instance Show (Registry inputs outputs) where - show (Registry vs fs ss ms) = - toS $ unlines [ - describeValues vs + show (Registry vs fs ss@(Specializations ss') ms@(Modifiers ms')) = + toS . unlines $ [ + "Values\n" + , describeValues vs + , "Constructors\n" , describeFunctions fs - , describeSpecializations ss - , describeModifiers ms ] + <> (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)) @@ -125,6 +133,14 @@ -- or for faster compile-time resolution with the make function normalize :: Registry ins out -> Registry (Normalized ins) (Normalized out) normalize (Registry vs fs ss ms) = Registry vs fs ss ms + +-- | Remove the parameters list of the registry and replace it with an empty type +-- This makes it easier to read compilation errors where less types are being displayed +-- On the other hand the resulting registry cannot be type-checked anymore when trying to get values out of it +eraseTypes :: Registry ins out -> Registry '[ERASED_TYPES] '[ERASED_TYPES] +eraseTypes (Registry values functions specializations modifiers) = Registry values functions specializations modifiers + +data ERASED_TYPES -- | The empty Registry end :: Registry '[] '[] diff --git a/src/Data/Registry/Statistics.hs b/src/Data/Registry/Statistics.hs --- a/src/Data/Registry/Statistics.hs +++ b/src/Data/Registry/Statistics.hs @@ -39,7 +39,7 @@ -- 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]) functions specializations modifiers) + (makeUntyped targetType (Context [(targetType, Nothing)]) functions specializations modifiers) of Left e -> diff --git a/test/Test/Data/Registry/Internal/GensRegistry.hs b/test/Test/Data/Registry/Internal/GensRegistry.hs --- a/test/Test/Data/Registry/Internal/GensRegistry.hs +++ b/test/Test/Data/Registry/Internal/GensRegistry.hs @@ -36,9 +36,12 @@ +: 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 diff --git a/test/Test/Data/Registry/Internal/MakeSpec.hs b/test/Test/Data/Registry/Internal/MakeSpec.hs --- a/test/Test/Data/Registry/Internal/MakeSpec.hs +++ b/test/Test/Data/Registry/Internal/MakeSpec.hs @@ -13,6 +13,7 @@ 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 @@ -22,9 +23,9 @@ -- put one of the input types to build already in the list of -- types being built - let context = Context (target : _contextStack context') + let context = Context ((target, Nothing) : _contextStack context') - let result = runStackWithValues values (makeInputs [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 Right _ -> failure diff --git a/test/Test/Data/Registry/Internal/RegistrySpec.hs b/test/Test/Data/Registry/Internal/RegistrySpec.hs --- a/test/Test/Data/Registry/Internal/RegistrySpec.hs +++ b/test/Test/Data/Registry/Internal/RegistrySpec.hs @@ -29,7 +29,7 @@ value <- forAll $ gen @Int values <- forAll $ gen @Values let listTypeRep = dynTypeRep . toDyn $ [value] - let context = Context [listTypeRep] -- when trying to build a [Int] + let context = Context [(listTypeRep, Nothing)] -- when trying to build a [Int] let specializations = Specializations [Specialization (pure listTypeRep) (createValue value)] (fromValueDyn <$> findValue (valueDynTypeRep (createValue value)) context specializations values) === Just (Just value) diff --git a/test/Test/Data/Registry/Internal/TypesSpec.hs b/test/Test/Data/Registry/Internal/TypesSpec.hs --- a/test/Test/Data/Registry/Internal/TypesSpec.hs +++ b/test/Test/Data/Registry/Internal/TypesSpec.hs @@ -9,7 +9,7 @@ import Type.Reflection test_specialized_context_order = prop "there are preferrable specializations than other in a given context" $ do - let c1 = Context [f, e, d, c, b, a] + let c1 = Context (fmap (\t -> (t, Nothing)) $ [f, e, d, c, b, a]) let s1 = specializedContext c1 (Specialization (a :| [c]) (createValue A)) let s2 = specializedContext c1 (Specialization (a :| [e]) (createValue A)) let s3 = specializedContext c1 (Specialization (c :| [f]) (createValue A))