packages feed

registry 0.1.9.3 → 0.2.0.0

raw patch · 29 files changed

+234/−472 lines, 29 files

Files

registry.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: a119d8aff497400e50a6bd878674be085b5225c5ab510f7ced5b47549ee2b895+-- hash: 6557ba917c4e8ae98b72a5b1b743bccc3d26bef98070e9e3cb45e22a03cbc2a6  name:           registry-version:        0.1.9.3+version:        0.2.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.
src/Data/Registry/Dot.hs view
@@ -10,37 +10,20 @@   module D , makeDot , makeDotEither-, makeDotFast-, makeDotUnsafe ) where  import           Data.Registry.Internal.Dot as D import           Data.Registry.Statistics import           Data.Registry.Registry-import           Data.Registry.Solver 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, Contains a out, Solvable ins out)-  => Registry ins out-  -> Dot-makeDot = makeDotUnsafe @a---- | Similar to `make` but does not check if `a` can be made out of the Regisry---   You can use this version to get faster compilation times-makeDotFast :: forall a ins out . (Typeable a, Contains a out)-  => Registry ins out-  -> Dot-makeDotFast = makeDotUnsafe @a+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 'Regisry'+-- | 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 r = toDot . operations <$> makeStatisticsEither @a r---- | Similar to `make` but does not check if `a` can be made out of the 'Regisry'---   and throws an exception if that's not the case-makeDotUnsafe :: forall a ins out . (Typeable a) => Registry ins out -> Dot-makeDotUnsafe = toDot . operations . makeStatisticsUnsafe @a
src/Data/Registry/Internal/Reflection.hs view
@@ -15,7 +15,7 @@ #else import           Protolude       as P hiding (intercalate, TypeRep, isPrefixOf, (<>)) #endif-import           Type.Reflection+import           Type.Reflection as Reflection import           GHC.Exts  -- | Return true if the type of this type rep represents a function@@ -27,11 +27,11 @@  -- | Show the full type of a typeable value showFullValueType :: Typeable a => a -> Text-showFullValueType = showTheFullValueType . typeOf+showFullValueType = showTheFullValueType . Reflection.typeOf  -- | Show the full type of a typeable function showFullFunctionType :: Typeable a => a -> ([Text], Text)-showFullFunctionType = showTheFullFunctionType . typeOf+showFullFunctionType = showTheFullFunctionType . Reflection.typeOf  -- | Show the full type of a typeable value --   where nested types like @IO[Int]@ or functions are represented and
src/Data/Registry/Make.hs view
@@ -33,80 +33,47 @@ import           Data.Registry.Internal.Stack import           Data.Registry.Internal.Types import           Data.Registry.Registry-import           Data.Registry.Solver import qualified Prelude                         (error) import           Protolude                       as P hiding (Constructor) import           Type.Reflection --- | For a given registry make an element of type a---   We want to ensure that a is indeed one of the return types---   We also try to statically check if there aren't other possible errors-make :: forall a ins out .-     (Typeable a, Contains a out, Solvable ins out)-  => Registry ins out-  -> a-make = makeUnsafe---- | Same as make but without the solvable constraint to compile faster---   in tests for example-makeFast :: forall a ins out .-     (Typeable a, Contains a out)-  => Registry ins out-  -> a-makeFast = makeUnsafe---- | 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), Nothing)])---- | This version of `make` only execute checks at runtime---   this can speed-up compilation when writing tests or in ghci-makeUnsafe :: forall a ins out . (Typeable a) => Registry ins out -> a-makeUnsafe registry =+-- | Make an element of type 'a' out of the registry+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) --- * SPECIALIZED VALUES+-- | 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 = makeEitherWithContext (Context [(someTypeRep (Proxy :: Proxy a), Nothing)]) --- | make for specialized values-makeSpecialized :: forall a b ins out . (Typeable a, Typeable b, Contains b out, Solvable ins out)  => Registry ins out -> b-makeSpecialized = makeSpecializedUnsafe @a @b+-- * SPECIALIZED VALUES  -- | make for specialized values-makeSpecializedPath :: forall path b ins out . (PathToTypeReps path, Typeable b, Contains b out, Solvable ins out)  => Registry ins out -> b-makeSpecializedPath = makeSpecializedPathUnsafe @path @b---- | makeFast for specialized values-makeSpecializedFast :: forall a b ins out . (Typeable a, Typeable b, Contains b out) => Registry ins out -> b-makeSpecializedFast = makeSpecializedUnsafe @a @b---- | makeFast for specialized values-makeSpecializedPathFast :: forall path b ins out . (PathToTypeReps path, Typeable b, Contains b out) => Registry ins out -> b-makeSpecializedPathFast = makeSpecializedPathUnsafe @path @b---- | makeUnsafe for specialized values-makeSpecializedUnsafe :: forall a b ins out . (Typeable a, Typeable b) => Registry ins out -> b-makeSpecializedUnsafe registry =+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) --- | makeUnsafe for specialized values-makeSpecializedPathUnsafe :: forall path b ins out . (PathToTypeReps path, Typeable b) => Registry ins out -> b-makeSpecializedPathUnsafe registry =+-- | make for specialized values+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) --- | makeEither for specialized values+-- | 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 = makeEitherWithContext (Context [(someTypeRep (Proxy :: Proxy a), Nothing), (someTypeRep (Proxy :: Proxy b), Nothing)]) --- | makeEither for specialized values+-- | 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 (fmap (\t -> (t, Nothing)) $ toList $ someTypeReps (Proxy :: Proxy path)))+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
src/Data/Registry/RIO.hs view
@@ -176,7 +176,7 @@ unsafeRunDynamicWithStop :: forall a ins out m . (Typeable a, MonadIO m) => Registry ins out -> m (a, Stop) unsafeRunDynamicWithStop registry = liftIO $ do   is <- createInternalState-  (a, _) <- runRIO (makeUnsafe @(RIO a) registry) (Stop is)+  (a, _) <- runRIO (make @(RIO a) registry) (Stop is)   pure (a, Stop is)  -- | Lift a 'Warmup' action into the 'RIO` monad
src/Data/Registry/Registry.hs view
@@ -5,8 +5,7 @@ {-# LANGUAGE UndecidableInstances  #-}  {- |-  A registry supports the creation of values out of existing values and-  functions.+  A registry supports the creation of values out of existing values and functions.    It contains 4 parts: @@ -24,7 +23,9 @@   >   <: 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.+  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: @@ -93,20 +94,31 @@  -- | Store an element in the registry --   Internally elements are stored as 'Dynamic' values-register :: (Typeable a)+--   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 (TypedValue v) (Registry (Values vs) functions specializations modifiers) =+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 (TypedValue v) (Registry (Values vs) functions specializations modifiers) =   Registry (Values (v : vs)) functions specializations modifiers -register (TypedFunction f) (Registry (Values vs) (Functions fs) 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 - Alternative to register where the parentheses can be ommitted+-- | 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)-(+:) = register+(+:) = registerUnchecked  -- Unification of +: and <+> infixr 5 <:@@ -116,13 +128,16 @@ instance (insr ~ (ins1 :++ ins2), outr ~ (out1 :++ out2)) => AddRegistryLike (Registry ins1 out1) (Registry ins2 out2) (Registry insr outr) where   (<:) = (<+>) -instance (Typeable 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, 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, 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@@ -138,6 +153,12 @@  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 myFunctionWithKnownInputs <: r else r+unsafeCoerce :: Registry ins out -> Registry ins1 out1+unsafeCoerce (Registry a b c d) = Registry a b c d+ -- | The empty Registry end :: Registry '[] '[] end = Registry (Values []) (Functions []) (Specializations []) (Modifiers [])@@ -170,104 +191,64 @@ 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, Contains a out, Typeable b)-  => b-  -> Registry ins out-  -> Registry ins out-specialize = specializeUnsafe @a @b @ins @out--specializePath :: forall path b ins out . (PathToTypeReps path, IsSubset path out, Typeable b)-  => b-  -> Registry ins out-  -> Registry ins out-specializePath = specializePathUnsafe @path @b @ins @out---- | This is similar to specialize but additionally uses the 'Show' instance of @b@---   to display more information when printing the registry out-specializeVal :: forall a b ins out . (Typeable a, Contains a out, Typeable b, Show b)-  => b-  -> Registry ins out-  -> Registry ins out-specializeVal = specializeUnsafeVal @a @b @ins @out--specializePathVal :: forall path b ins out . (PathToTypeReps path, IsSubset path out, Typeable b, Show b)-  => b-  -> Registry ins out-  -> Registry ins out-specializePathVal = specializePathUnsafeVal @path @b @ins @out--specializeValTo :: forall m a b ins out . (Applicative m, Typeable a, Contains a out, Typeable (m b), Typeable b, Show b)-  => b-  -> Registry ins out-  -> Registry ins out-specializeValTo = specializeUnsafeValTo @m @a @b @ins @out--specializePathValTo :: forall m path b ins out . (Applicative m, PathToTypeReps path, IsSubset path out, Typeable (m b), Typeable b, Show b)-  => b-  -> Registry ins out-  -> Registry ins out-specializePathValTo = specializePathUnsafeValTo @m @path @b @ins @out- -- | For a given type `a` being currently built --   when a value of type `b` is required pass a specific --   value-specializeUnsafe :: forall a b ins out . (Typeable a, Typeable b)+specialize :: forall a b ins out . (Typeable a, Typeable b)   => b   -> Registry ins out   -> Registry ins out-specializeUnsafe b (Registry values functions (Specializations c) modifiers) = Registry+specialize b (Registry values functions (Specializations c) modifiers) = Registry   values   functions   (Specializations (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (createTypeableValue b) : c))   modifiers -specializePathUnsafe :: forall path b ins out . (PathToTypeReps path, Typeable b)+specializePath :: forall path b ins out . (PathToTypeReps path, Typeable b)   => b   -> Registry ins out   -> Registry ins out-specializePathUnsafe b (Registry values functions (Specializations c) modifiers) = Registry+specializePath b (Registry values functions (Specializations c) modifiers) = Registry   values   functions   (Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (createTypeableValue b) : c))   modifiers -specializeUnsafeVal :: forall a b ins out . (Typeable a, Contains a out, Typeable b, Show b)+specializeVal :: forall a b ins out . (Typeable a, Contains a out, Typeable b, Show b)   => b   -> Registry ins out   -> Registry ins out-specializeUnsafeVal b (Registry values functions (Specializations c) modifiers) = Registry+specializeVal b (Registry values functions (Specializations c) modifiers) = Registry   values   functions   (Specializations (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (createValue b) : c))   modifiers -specializePathUnsafeVal :: forall path b ins out . (PathToTypeReps path, Typeable b, Show b)+specializePathVal :: forall path b ins out . (PathToTypeReps path, Typeable b, Show b)   => b   -> Registry ins out   -> Registry ins out-specializePathUnsafeVal b (Registry values functions (Specializations c) modifiers) = Registry+specializePathVal b (Registry values functions (Specializations c) modifiers) = Registry   values   functions   (Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (createValue b) : c))   modifiers -specializeUnsafeValTo :: forall m a b ins out . (Applicative m, Typeable a, Typeable (m b), Typeable b, Show b)+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-specializeUnsafeValTo b (Registry values functions (Specializations c) modifiers) = Registry+specializeValTo b (Registry values functions (Specializations c) modifiers) = Registry   values   functions   (Specializations (Specialization (pure $ someTypeRep (Proxy :: Proxy a)) (liftProvidedValue @m b) : c))   modifiers -specializePathUnsafeValTo :: forall m path b ins out . (Applicative m, PathToTypeReps path, Typeable (m b), Typeable b, Show b)+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-specializePathUnsafeValTo b (Registry values functions (Specializations c) modifiers) = Registry+specializePathValTo b (Registry values functions (Specializations c) modifiers) = Registry   values   functions   (Specializations (Specialization (someTypeReps (Proxy :: Proxy path)) (liftProvidedValue @m b) : c))@@ -285,19 +266,11 @@  -- | 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, Contains a out)-  => (a -> a)-  -> Registry ins out-  -> Registry ins out-tweak = tweakUnsafe---- | Once a value has been computed allow to modify it before storing---   it-tweakUnsafe :: forall a ins out . (Typeable a)+tweak :: forall a ins out . (Typeable a)   => (a -> a)   -> Registry ins out   -> Registry ins out-tweakUnsafe f (Registry values functions specializations (Modifiers mf)) = Registry values functions specializations+tweak f (Registry values functions specializations (Modifiers mf)) = Registry values functions specializations   (Modifiers ((someTypeRep (Proxy :: Proxy a), createConstModifierFunction f) : mf))  -- * Memoization@@ -310,18 +283,12 @@ -- | 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), Contains (m a) out)-  => Registry ins out-  -> IO (Registry ins out)-memoize = memoizeUnsafe @m @a @ins @out---- | Memoize an action for a given type but don't check if the value is part of the registry outputs-memoizeUnsafe :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a))+memoize :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a))   => Registry ins out   -> IO (Registry ins out)-memoizeUnsafe (Registry values functions specializations (Modifiers mf)) = do+memoize (Registry values functions specializations (Modifiers mf)) = do   cache <- newCache @a-  let modifiers = Modifiers ((someTypeRep (Proxy :: Proxy (m a)), \key -> createFunction (fetch @a @m cache key)) : mf)+  let modifiers = Modifiers ((someTypeRep (Proxy :: Proxy (m a)), createFunction . fetch @a @m cache) : mf)   pure $ Registry values functions specializations modifiers  -- | Memoize *all* the output actions of a Registry when they are creating effectful components@@ -348,19 +315,9 @@  instance {-# OVERLAPPING #-} (MonadIO m, Typeable a, Typeable (m a), MemoizedActions rest) => MemoizedActions (m a : rest) where   memoizeActions (MemoizeRegistry r) = do-    r' <- memoizeUnsafe @m @a r+    r' <- memoize @m @a r     memoizeActions (makeMemoizeRegistry @rest r')  instance (MemoizedActions rest) => MemoizedActions (a : rest) where   memoizeActions (MemoizeRegistry r) =     memoizeActions (makeMemoizeRegistry @rest r)---- * DEPRECATIONS--{-# DEPRECATED singleton "use memoize instead" #-}-singleton :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a), Contains (m a) out) => Registry ins out -> IO (Registry ins out)-singleton = memoize @m @a @ins @out--{-# DEPRECATED singletonUnsafe "use memoizeUnsafe instead" #-}-singletonUnsafe :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a)) => Registry ins out -> IO (Registry ins out)-singletonUnsafe = memoizeUnsafe @m @a @ins @out
src/Data/Registry/Solver.hs view
@@ -8,9 +8,6 @@ {- |   Type level functions to statically assess   if a value can be built out of a Registry--  For now we don't check if there could be cycles in-    the registry functions -} module Data.Registry.Solver where @@ -27,26 +24,52 @@   Output (i -> o) = Output o   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 ""+    )+  CanMake a (a ': _els) _t = ()+  CanMake a (_b ': els) t = CanMake a els t++-- | Compute if each element of a list of types is contained in+-- another list+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 a type is contained in a list of types type family Contains (a :: Type) (els :: [Type]) :: Constraint where-  Contains a '[] = TypeError (Text "No element of type " ':<>: 'ShowType a ':<>: 'Text " can be built out of the registry")-  Contains a (a ': els) = ()-  Contains a (b ': els) = Contains a els+  Contains a els = Contains1 a els els +-- | Compute if a type is contained in a list of types+type family Contains1 (a :: Type) (els :: [Type]) (target :: [Type]) :: Constraint where+  Contains1 a '[] target = TypeError ('ShowType a ':<>: Text " cannot be found in " ':<>: 'ShowType target)+  Contains1 a (a ': els) t = ()+  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 --- | Compute if each element of a list of types is contained in--- another list-class IsSubset (ins :: [Type]) (out :: [Type])-instance IsSubset '[] out-instance (Contains a out, IsSubset els out) => IsSubset (a ': els) out- -- | From the list of all the input types and outputs types of a registry --   Can we create all the output types? class Solvable (ins :: [Type]) (out :: [Type])-instance (IsSubset ins out) => Solvable ins out +instance (IsSubset ins out ()) => Solvable ins out  -- | Extracted from the typelevel-sets project and adapted for the Registry datatype --   This union deduplicates elements only if they appear in contiguously@@ -59,8 +82,8 @@ -- | Return '[a] only if it is not already in the list of types type family FindUnique (a :: Type) (as :: [Type]) :: [Type] where   FindUnique a '[] = '[a]-  FindUnique a (a ': rest) = '[]-  FindUnique a (b ': rest) = FindUnique a rest+  FindUnique a (a ': _rest) = '[]+  FindUnique a (_b ': rest) = FindUnique a rest  type family Normalized (as :: [Type]) :: [Type] where   Normalized '[] = '[]
src/Data/Registry/State.hs view
@@ -14,7 +14,7 @@ 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) => 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@@ -23,7 +23,7 @@ addFunToUnsafe = addToRegistryUnsafe @b . funTo @m  -- | Add an element to the registry without changing its type, in the State monad-addFunS :: (Typeable a, IsSubset (Inputs a) out, MonadState (Registry ins out) m) => a -> m ()+addFunS :: (Typeable a, IsSubset (Inputs a) out a, MonadState (Registry ins out) m) => a -> m () addFunS = modify . addFun  -- | Add an element to the registry without changing its type, in the State monad@@ -32,7 +32,7 @@ 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, 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@@ -41,7 +41,7 @@ addToUnsafeS = modify . addFunToUnsafe @n @a @b  -- | Add an element to the registry without changing its type-addFun :: (Typeable a, IsSubset (Inputs a) out) => a -> Registry ins out -> Registry ins out+addFun :: (Typeable a, IsSubset (Inputs a) out a) => a -> Registry ins out -> Registry ins out addFun = addToRegistry . fun  -- | Add an element to the registry without changing its type@@ -50,7 +50,7 @@ addFunUnsafe = addToRegistryUnsafe . fun  -- | Register modifications of elements which types are already in the registry-addToRegistry :: (Typeable a, IsSubset (Inputs a) out) => Typed a -> Registry ins out -> Registry ins out+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
src/Data/Registry/Statistics.hs view
@@ -4,26 +4,25 @@ module Data.Registry.Statistics (   module S , makeStatistics-, makeStatisticsFast , makeStatisticsEither-, makeStatisticsUnsafe ) 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.Solver import           Data.Registry.Registry import           Prelude                           (error) import           Protolude import           Type.Reflection -makeStatistics :: forall a ins out . (Typeable a, Contains a out, Solvable ins out) => Registry ins out -> Statistics-makeStatistics = makeStatisticsUnsafe @a--makeStatisticsFast :: forall a ins out .  (Typeable a, Contains a out) => Registry ins out -> Statistics-makeStatisticsFast = makeStatisticsUnsafe @a+-- | 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 registry =+  case makeStatisticsEither @a registry of+    Right a -> a+    Left  e -> Prelude.error (toS e)  -- | Return `Statistics` as the result of the creation of a value --   of a given type@@ -48,11 +47,3 @@          other ->           other---- | 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)-makeStatisticsUnsafe  :: forall a ins out . (Typeable a) => Registry ins out -> Statistics-makeStatisticsUnsafe registry =-  case makeStatisticsEither @a registry of-    Right a -> a-    Left  e -> Prelude.error (toS e)
src/Data/Registry/TH.hs view
@@ -1,22 +1,12 @@-{-# LANGUAGE QuasiQuotes     #-}-{-# LANGUAGE TemplateHaskell #-}- module Data.Registry.TH (   TypeclassOptions-, checkRegistry , makeTypeclass , makeTypeclassWith-, unsafeCoerceRegistry ) where -import           Data.List                  (nubBy)-import           Data.Registry-import           Data.Set                   (difference)-import qualified Data.Set                   as Set import           Data.Text                  as T (drop, splitOn) import           Language.Haskell.TH import           Language.Haskell.TH.Syntax-import           Prelude                    (String) import           Protolude                  hiding (Type)  {-@@ -132,87 +122,3 @@ -- | Remove the module name from a qualified name dropQualified :: Name -> Name dropQualified name =  maybe name (mkName . toS) (lastMay (T.splitOn "." (show name)))---- | Check that all the input values of a registry can be built---   This will check that all the input values can be built out of the registry---   and also return a normalized registry where the types have been de-duplicated------   Usage:------     initialRegistry :: Registry _ _---     initialRegistry = val x +: fun y +: ... +: end------     -- Put the definition in another module! (see: https://gitlab.haskell.org/ghc/ghc/issues/9813)------     checkedRegistry :: Registry _ _---     checkedRegistry = $(checkRegistry initialRegistry)----checkRegistry :: Name -> Q Exp-checkRegistry registryName = do-  registryInfo <- reify registryName--  case registryInfo of--    VarI _ registryType _ ->-      case registryType of-        AppT (AppT (ConT actualType) ins) out -> do-          let actual = show actualType :: String-          if actual == "Data.Registry.Registry.Registry" then do--            let insTypes = fst <$> typesOf ins-            let outTypes = fst <$> typesOf out-            let missingFromOutputs = Set.fromList insTypes `difference` Set.fromList outTypes--            -- We check that all the input types to functions can be created-            -- from outputs in the registry-            if null missingFromOutputs then-              [| unsafeCoerceRegistry $(varE registryName) :: $(returnQ $ AppT (AppT (ConT actualType) (normalizeTypes ins)) (normalizeTypes out)) |]-            else-              reportErrorWith $ "Some input values cannot be built from the registry. " <> show (Set.toList missingFromOutputs)--          else-            reportErrorWith $ "We can only check the coverage of a Registry, got: " <> actual--        other ->-          reportErrorWith $ "We can only check the coverage of a Registry. Use `checked = $(checkRegistry 'registry), Got: " <> show other--    other ->-      reportErrorWith $ "We can only check the coverage of a Registry. Use `checked = $(checkRegistry 'registry). Got: " <> show other--   where reportErrorWith msg = do-           reportError msg-           varE registryName----- | Return a list of type name + type from a type level list of types-typesOf :: Type -> [(String, Type)]-typesOf (AppT (AppT PromotedConsT t) rest) = (typeName t, t) : typesOf rest-typesOf _ = []---- | Extract the name of a type---   There is a bit of massaging for tuple and arrow types for better display-typeName :: Type -> String-typeName (ConT n) = nameBase n-typeName (AppT (AppT (TupleT 2) t1) t2) = "(" <> typeName t1 <> "," <> typeName t2 <> ")"-typeName (AppT (AppT (AppT (TupleT 3) t1) t2) t3) = "(" <> typeName t1 <> "," <> typeName t2 <> "," <> typeName t3 <> ")"-typeName (AppT (AppT (AppT (AppT (TupleT 4) t1) t2) t3) t4) = "(" <> typeName t1 <> "," <> typeName t2 <> "," <> typeName t3 <> "," <> typeName t4 <> ")"-typeName (AppT (TupleT i) t) = "Tuple" <> show i <> "(" <> typeName t <> ")"-typeName (AppT (AppT ArrowT t1) t2) = typeName t1 <> " -> " <> typeName t2-typeName (AppT (AppT (AppT ArrowT t1) t2) t3) = typeName t1 <> " -> " <> typeName t2 <> " -> " <> typeName t3-typeName (AppT (AppT (AppT (AppT ArrowT t1) t2) t3) t4) = typeName t1 <> " -> " <> typeName t2 <> " -> " <> typeName t3 <> " -> " <> typeName t4-typeName (AppT ArrowT t) = typeName t <> " -> "--typeName (AppT ListT t) = "[" <> typeName t <> "]"-typeName (AppT t1 t2) = typeName t1 <> "(" <> typeName t2 <> ")"-typeName t = show t---- | Return a deduplicated list of types from a list of types-normalizeTypes :: Type -> Type-normalizeTypes t =-  rebuild $ nubBy (\(n1, _) (n2, _) -> n1 == n2) (typesOf t)-  where rebuild []               = SigT PromotedNilT (AppT ListT StarT)-        rebuild ((_, t1) : rest) = AppT (AppT PromotedConsT t1) (rebuild rest)---- | This is unsafe and is only used in the context of the checkRegistry function-unsafeCoerceRegistry :: Registry ins out -> Registry ins1 out1-unsafeCoerceRegistry (Registry a b c d) = Registry a b c d
test/Test/Data/Registry/GenSpec.hs view
@@ -76,13 +76,13 @@ -- | 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-  <: funTo @Gen Age-  <: fun (genList @Department)-  <: fun (genList @Employee)   <: fun genInt   <: fun genText   <: fun genDouble@@ -120,10 +120,10 @@ 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 = withFrozenCallStack $ get >>= P.lift . forAll . makeUnsafe @(Gen 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 f = modify $ tweakUnsafe @(Gen a) f+tweakGen f = modify $ tweak @(Gen a) f  runR :: Monad m => RegistryProperty m a -> PropertyT m a runR = runWith registry
test/Test/Data/Registry/Internal/Gens.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds             #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE TemplateHaskell       #-}  {-# OPTIONS_GHC -fno-warn-missing-monadfail-instances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}@@ -9,16 +8,15 @@ module Test.Data.Registry.Internal.Gens where  import           Data.Registry-import           Data.Registry.TH import           Hedgehog import           Protolude import           Test.Data.Registry.Internal.GensRegistry  -- Hedgehog generators for the internal types-registry = $(checkRegistry 'gensRegistry)+registry = normalize gensRegistry  forall :: forall a . _ => PropertyT IO a forall = forAll $ gen @a  gen :: forall a . _ => Gen a-gen = makeFast registry+gen = make registry
test/Test/Data/Registry/Internal/GensRegistry.hs view
@@ -18,37 +18,41 @@ -- 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)+  -- specializations+  <: funTo @Gen Modifiers   <: fun   (genList @(SomeTypeRep, ModifierFunction))   <: fun   (genPair @SomeTypeRep @ModifierFunction)-  <: fun   (genPair @(NonEmpty SomeTypeRep) @Value)+  <: fun   genModifierFunction+  <: funTo @Gen Specializations+  <: fun   (genList @Specialization)+  <: funTo @Gen Specialization+  -- functions+  <: funTo @Gen Functions   <: fun   (genList @Function)-  <: fun   (genList @SomeTypeRep)+  <: funTo @Gen Function+  <: funTo @Gen FunctionDescription+  -- type reps   <: fun   (genList @(SomeTypeRep, Maybe SomeTypeRep))-  <: fun   (genList @Value)-  <: fun   (genList @Function)-  <: fun   (genMaybe @Text)-  <: fun   (genMaybe @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-  <: fun   genDynamic-  <: fun   genSomeTypeRep-  + -- * generators newtype TextToInt = TextToInt (Text -> Int) instance Show TextToInt where show _ = "<function>"@@ -67,7 +71,7 @@ genValues :: Gen (Int, Values) genValues = do   value  <- genInt-  values  <- makeUnsafe @(Gen Values) gensRegistry+  values  <- make @(Gen Values) gensRegistry   pure (value, createValue value `addValue` values)  genSomeTypeRep :: Gen Value -> Gen SomeTypeRep
test/Test/Data/Registry/Make/MakeSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds       #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Data.Registry.Make.MakeSpec where@@ -28,7 +27,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)+  let explosive = make @Text (registerUnchecked (fun add1) $ registerUnchecked (fun dda1) end)   r <- liftIO $ try (print explosive)   case r of     Left (_ :: SomeException) -> assert True
test/Test/Data/Registry/Make/SpecializationSpec.hs view
@@ -14,9 +14,9 @@ -- | 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 =    val (Config 3)+    do let r =    fun newUseConfig2                <: fun newUseConfig1-               <: fun newUseConfig2+               <: val (Config 3)        let r' = specialize @UseConfig1 (Config 1) $                 specialize @UseConfig2 (Config 2) r        pure (printConfig1 (make @UseConfig1 r'), printConfig2 (make @UseConfig2 r'))@@ -28,9 +28,9 @@ --   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 =    val (Config 3)+    do let r =    fun newClient1                <: fun newUseConfig-               <: fun newClient1+               <: val (Config 3)        let r' = specialize @Client1 (Config 1) $                 specialize @UseConfig (Config 2) r        pure $ printClientConfig1 (make @Client1 r')@@ -43,11 +43,11 @@ --   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 =    val (Config 3)-               <: fun newUseConfig+    do let r =    fun newBase                <: fun newClient1                <: fun newClient2-               <: fun newBase+               <: fun newUseConfig+               <: val (Config 3)        let r' = specialize @Client1 (Config 1) $                 specialize @Client2 (Config 2) r        pure $ printBase (make @Base r')@@ -95,16 +95,16 @@ -- | 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 =    valTo @RIO (Config 3)-               <: funTo @RIO newUseConfig+    do let r =    funTo @RIO newBase2                <: funTo @RIO newClient1                <: funTo @RIO newClient2-               <: funTo @RIO newBase2+               <: 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 -       printBase2 <$> (unsafeRun @Base2 r')+       printBase2 <$> unsafeRun @Base2 r'    c1 === Config 1   c2 === Config 2@@ -156,16 +156,15 @@  appRegistry :: Registry _ _ appRegistry =-  specializeUnsafeVal @Sql (SupervisorConfig "for sql in general") .-  specializePathUnsafeVal @[StatsStore, Sql] (SupervisorConfig "for sql under the stats store") .-  specializeUnsafeVal @TwitterClient (SupervisorConfig "for the twitter client") $-     val (SupervisorConfig "default")-  +: fun newTwitterClient-  +: fun newSupervisor-  +: fun newStatsStore-  +: fun newSql-  +: fun App-  +: end+  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@@ -224,19 +223,19 @@  aRegistryIO :: IO (Registry _ _) aRegistryIO = memoizeAll @IO $-     specializePathUnsafeValTo @IO @[IO ToOverride, IO InCommon] (SomeConfig "specialized config") $-     valTo @IO (SomeConfig "default config")+     specializePathValTo @IO @[IO ToOverride, IO InCommon] (SomeConfig "specialized config") $+     funTo @IO SomeData   <: funTo @IO newToKeepDefault   <: funTo @IO newToOverride   <: funTo @IO InCommon-  <: funTo @IO SomeData+  <: valTo @IO (SomeConfig "default config")  test_make_specialized_values = test "specialized values can be made" $ do-  let r =    val (Config 3)-          <: fun newUseConfig-          <: fun newClient1+  let r =    fun newBase2           <: fun newClient2-          <: fun newBase2+          <: fun newClient1+          <: fun newUseConfig+          <: val (Config 3)    let r' = specializePathVal @[Base2, Client1, UseConfig] (Config 1) .                 specializeVal @UseConfig (Config 2) $ r
test/Test/Data/Registry/Make/TweakingSpec.hs view
@@ -11,9 +11,9 @@ -- | Modification of stored values test_tweak = test "created values can be modified prior to being stored" $ do   c1 <- liftIO $-    do let r =    val (Config 1)+    do let r =    fun newAppUsingConfig1                <: fun newUseConfig1-               <: fun newAppUsingConfig1+               <: val (Config 1)         let r' = tweak (\(UseConfig1 _) -> UseConfig1 (Config 10)) r        pure (printAppConfig (make @AppUsingConfig1 r'))@@ -32,9 +32,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)+    do let r =    fun A                <: fun B-               <: fun A+               <: val (C 1)         let r' = specialize @A @C (C 2) r        let r'' = tweak (\(B (C _)) -> B (C 3)) r'
test/Test/Data/Registry/MonadRandomSpec.hs view
@@ -101,7 +101,7 @@ 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+       <: registryProd    client  <- liftIO $ make @(IO Client) registry'   results <- liftIO $ replicateM 10 $ client & runClient@@ -114,7 +114,7 @@ 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+       <: registryProd    client  <- liftIO $ make @(IO Client) registry'   results <- liftIO $ replicateM 10 $ client & runClient
test/Test/Data/Registry/RegistrySpec.hs view
@@ -14,7 +14,7 @@  test_create_value_with_no_args_constructor = prop "no args constructors are considered as functions" $ do   ref         <- liftIO $ newIORef ("" :: Text)-  let registry' = funTo @IO ref +: funTo @IO refLogger +: registry+  let registry' = funTo @IO refLogger +: funTo @IO ref +: registry    Logger {..} <- liftIO $ make @(IO Logger) registry'   liftIO $ info "hey"
test/Test/Data/Registry/SimpleExamples.hs view
@@ -40,18 +40,17 @@ toText2 :: Text1 -> Text2 toText2 (Text1 t) = Text2 t -registry1 :: Registry [Int, Text, Text1] [Int, Text, Text1, Text2]+registry1 :: Registry [Text1, Text, Int] [Text2, Text1, Text, Int] registry1 = normalize $-     val int1-  <: fun add1+     fun toText2   <: fun add2-  <: fun toText2+  <: fun text1+  <: fun add1+  <: val int1  countSize :: Text -> Maybe Int countSize t = Just (T.length t) -m = make @Text $ fun (\(t::Text) -> t) +: end- made1 :: Text made1 = make @Text registry1 @@ -65,11 +64,10 @@ countSize1 :: Text -> Int1 countSize1 t = Int1 (T.length t) -registry2 :: Registry '[Int, Text] '[Int, Text, Int1] registry2 =-     fun int1+     fun countSize1   <: fun add1-  <: fun countSize1+  <: fun int1  made4 :: Int1 made4 = make @Int1 registry2@@ -86,24 +84,18 @@ unknown :: Double -> Text1 unknown _ = Text1 "text1" -registry3 :: Registry [Double, Int, Text] [Int, Text1, Text, Int1]-registry3 =-     val int1-  <: 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 {--wrong :: Text1-wrong = make @Text1 registry3+registry3 :: Registry [Double, Int, Text] [Int, Text1, Text, Int1]+registry3 =+     fun countSize1+  <: fun unknown+  <: fun add1+  <: val int1 -} --- | This version compiles but throws an exception at runtime-dangerous :: Text1-dangerous = makeUnsafe @Text1 registry3- -- | Example with an optional configuration --   The ProductionComponent will only be used if the ServiceConfig says we are in production newtype ProductionComponent = ProductionComponent { doItInProduction :: IO () }@@ -126,12 +118,12 @@ --   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 InProd f = Service { service = doItInProduction (unTag f ProductionConfig) }  registryWithOptionalComponents =-     val InDev-  <: fun newService+     fun newService   <: fun newProductionComponentBuilder   <: fun logging+  <: val InDev  makeService = make @Service registryWithOptionalComponents
test/Test/Data/Registry/SmallExample.hs view
@@ -63,8 +63,8 @@  -- | Create a registry for all constructors registry =-     funTo @IO (newS3 @IO)-  <: funTo @IO (newApplication @IO)+     funTo @IO (newApplication @IO)+  <: funTo @IO (newS3 @IO)   <: funTo @IO noLogging   <: funTo @IO newLinesCounter   <: valTo @IO (S3Config "bucket" "key")@@ -74,7 +74,7 @@ --   Since the registry contains all functions and values necessary to create the application --   Everything will work fine createApplication :: IO Application-createApplication = make @(IO Application) (funTo @IO noLogging +: registry)+createApplication = make @(IO Application) (funTo @IO noLogging <: registry)  test_create = test "create the application" $ do   app <- liftIO createApplication -- nothing should crash!
test/Test/Data/Registry/THSpec.hs view
@@ -6,7 +6,6 @@ module Test.Data.Registry.THSpec where  import           Data.Generics.Product.Typed-import           Data.Registry import           Data.Registry.TH import           Protolude import           Universum                   ((...))@@ -54,47 +53,3 @@ implementService n t = do   info "doing it" t   traceIt (show n)---- * Example of TemplateHaskell usage to check the completeness of a registry--add0 :: Int -> Text-add0 _ = ""--times2 :: Double -> Text-times2 n = show (n * 2)--reg0 :: Registry '[Int] '[Text, Int, Int]-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 [])---- | this compiles ok and de-duplicates types-reg1 :: Registry '[Int] '[Text, Int]-reg1 = $(checkRegistry 'reg0)---- Then we can use makeFast-value = makeFast @Int reg1--regIncomplete :: Registry [Double, Int] [Text, Text, Int, Int]-regIncomplete = fun times2 +: reg0---- | This does not compile--- reg2 :: Registry [Double, Int] [Text, Int]--- reg2 = $(checkRegistry 'regIncomplete)---- | Using the checkRegistry function with IO functions-addIO0 :: Int -> IO Text-addIO0 _ = pure ""--regIO0 :: Registry '[IO Int] '[IO Text, IO Int, IO Int]-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 [])--regIO1 :: Registry '[IO Int] '[IO Text, IO Int]-regIO1 = $(checkRegistry 'regIO0)---- Then we can use makeFast-valueIO = makeFast @(IO Int) regIO1
test/Test/Data/Registry/WarmupSpec.hs view
@@ -32,8 +32,8 @@           <: funTo @RIO newA           <: funTo @RIO newB           <: fun   (newC messagesRef)-          -    void $ withRIO (makeUnsafe @(RIO App) registry) $ const (pure ())++    void $ withRIO (make @(RIO App) registry) $ const (pure ())      ms <- liftIO $ readIORef messagesRef     ms === ["x"]
test/Test/Tutorial/Exercise2.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} @@ -10,11 +9,11 @@ registry :: Registry _ _ registry =      fun App-  <: fun newLogger-  <: fun newConsole   <: fun newUserInput-  <: fun newRng   <: fun newSecretReader+  <: fun newRng+  <: fun newConsole+  <: fun newLogger   <: val (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt")  newApp :: App
test/Test/Tutorial/Exercise3.hs view
@@ -12,18 +12,18 @@ silentLogger :: Logger IO silentLogger = Logger (const (pure ())) (const (pure ())) -silentRegistry = fun silentLogger +: registry+silentRegistry = fun silentLogger <: registry  newSilentApp :: App newSilentApp = make @App silentRegistry  newMisconfiguredApp :: App-newMisconfiguredApp = make @App (val (SecretReaderConfig "missing") +: registry)+newMisconfiguredApp = make @App (val (SecretReaderConfig "missing") <: registry)  newMisconfiguredSilentApp :: App-newMisconfiguredSilentApp = make @App (val (SecretReaderConfig "missing") +: silentRegistry)+newMisconfiguredSilentApp = make @App (val (SecretReaderConfig "missing") <: silentRegistry)  newMisconfiguredRngSilentApp :: App newMisconfiguredRngSilentApp = make @App $   specialize @(Rng IO) silentLogger $-  val (SecretReaderConfig "missing") +: registry+  val (SecretReaderConfig "missing") <: registry
test/Test/Tutorial/Exercise4.hs view
@@ -13,4 +13,4 @@ printApp :: IO () printApp = putStrLn $ unDot $ makeDot @App $   specialize @(Rng IO) silentLogger $-  val (SecretReaderConfig "missing") +: registry+  val (SecretReaderConfig "missing") <: registry
test/Test/Tutorial/Exercise5.hs view
@@ -27,11 +27,11 @@ registryIO :: Registry _ _ registryIO =      funTo @IO App-  <: funTo @IO newLogger-  <: funTo @IO newConsole   <: 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
test/Test/Tutorial/Exercise6.hs view
@@ -20,12 +20,12 @@ 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)+  <: funTo @IO newRng+  <: funTo @IO newLogger+  <: funTo @IO newConsole   <: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt")  newAppIO :: IO App
test/Test/Tutorial/Exercise7.hs view
@@ -15,7 +15,7 @@   pure (Logger putStrLn putStrLn)  newInitializedRegistry :: Registry _ _-newInitializedRegistry = fun newInitializedLogger +: registryIO+newInitializedRegistry = fun newInitializedLogger <: registryIO  newInitializedAppIO :: IO App newInitializedAppIO = make @(IO App) newInitializedRegistry
test/Test/Tutorial/Exercise8.hs view
@@ -1,30 +1,19 @@ {-# LANGUAGE DataKinds             #-} {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE TemplateHaskell       #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}  module Test.Tutorial.Exercise8 where  import           Data.Registry-import           Data.Registry.TH-import           Protolude import           Test.Tutorial.Application import           Test.Tutorial.Exercise2  erasedRegistry :: Registry '[ERASED_TYPES] '[ERASED_TYPES] erasedRegistry = eraseTypes registry -incorrectRegistry = fun (\(_::Int) (_::Logger IO) (_:: Console IO) -> App) +: registry--checkedRegistry = $(checkRegistry 'registry)--$(return [])--{---- this does not compile-checkedIncorrectRegistry = $(checkRegistry 'incorrectRegistry)--}- newErasedApp :: App-newErasedApp = makeUnsafe @App erasedRegistry+newErasedApp = make @App erasedRegistry++normalizedRegistry :: Registry _ _+normalizedRegistry = normalize registry