diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,17 @@ +Copyright (c) 2018 Eric Torreborre + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated +documentation files (the "Software"), to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, +and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of +the Software. Neither the name of specs nor the names of its contributors may be used to endorse or promote +products derived from this software without specific prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED +TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF +CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/registry.cabal b/registry.cabal new file mode 100644 --- /dev/null +++ b/registry.cabal @@ -0,0 +1,93 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 69724ea3bcc548733938f7f6e17f36c25bfcf15fe363bf71b446f0f7d0350137 + +name: registry +version: 0.1.0.0 +synopsis: the Registry data structure can be used 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. +category: Control +maintainer: etorreborre@yahoo.com +license: MIT +license-file: LICENSE.txt +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/etorreborre/registry + +library + exposed-modules: + Data.Registry + Data.Registry.Dot + Data.Registry.Internal.Cache + Data.Registry.Internal.Dynamic + Data.Registry.Internal.Make + Data.Registry.Internal.Operations + Data.Registry.Internal.Reflection + Data.Registry.Internal.Registry + Data.Registry.Internal.Stack + Data.Registry.Internal.Types + Data.Registry.Lift + Data.Registry.Make + Data.Registry.Registry + Data.Registry.RIO + Data.Registry.Solver + Data.Registry.Warmup + other-modules: + Paths_registry + hs-source-dirs: + src + default-extensions: FlexibleContexts FlexibleInstances LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings Rank2Types ScopedTypeVariables ScopedTypeVariables TupleSections TypeApplications TypeOperators + ghc-options: -Wall -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path + build-depends: + base >=4.7 && <5 + , exceptions <0.11 + , protolude <0.3 + , resourcet <1.3 + , text <2 + , transformers <0.6 + , transformers-base <0.5 + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: test.hs + other-modules: + Test.Data.Registry.DotSpec + Test.Data.Registry.Internal.CacheSpec + Test.Data.Registry.Internal.DynamicSpec + Test.Data.Registry.Internal.Gens + Test.Data.Registry.Internal.MakeSpec + Test.Data.Registry.Internal.ReflectionSpec + Test.Data.Registry.Internal.RegistrySpec + Test.Data.Registry.Make + Test.Data.Registry.SmallExample + Test.Data.Registry.WarmupSpec + Test.Tasty.Extensions + Paths_registry + hs-source-dirs: + test + default-extensions: FlexibleContexts FlexibleInstances LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings Rank2Types ScopedTypeVariables ScopedTypeVariables TupleSections TypeApplications TypeOperators + ghc-options: -Wall -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures -optP-Wno-nonportable-include-path + build-depends: + async <2.3 + , base >=4.7 && <5 + , exceptions <0.11 + , hedgehog <0.7 + , hedgehog-corpus <0.2 + , io-memoize <1.2 + , protolude <0.3 + , registry + , resourcet <1.3 + , tasty <1.2 + , tasty-discover <4.3 + , tasty-hedgehog <0.3 + , tasty-th <0.2 + , text <2 + , transformers <0.6 + , transformers-base <0.5 + default-language: Haskell2010 diff --git a/src/Data/Registry.hs b/src/Data/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry.hs @@ -0,0 +1,17 @@ +{- | + + Import this module if you want to access all the functionalities of the + Registry API + +-} +module Data.Registry ( + module M +) where + +import Data.Registry.RIO as M +import Data.Registry.Make as M +import Data.Registry.Registry as M +import Data.Registry.Lift as M +import Data.Registry.Solver as M +import Data.Registry.Warmup as M +import Data.Registry.Dot as M diff --git a/src/Data/Registry/Dot.hs b/src/Data/Registry/Dot.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Dot.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MonoLocalBinds #-} + +{- | + This modules provides functions to extract + a DOT graph (https://en.wikipedia.org/wiki/DOT_(graph_description_language) + out of a Registry. +-} +module Data.Registry.Dot ( + module O +, makeDot +, makeDotEither +, makeDotFast +, makeDotUnsafe +, makeOperationsEither +, makeOperationsUnsafe +) where + +import Data.Registry.Internal.Make +import Data.Registry.Internal.Operations as O +import Data.Registry.Internal.Stack +import Data.Registry.Internal.Types +import Data.Registry.Registry +import Data.Registry.Solver +import Prelude (error) +import Protolude +import Type.Reflection + +-- | 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 + +-- | Similar to `make` but does not check if `a` can be made out of the Regisry +-- 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 <$> makeOperationsEither @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 . makeOperationsUnsafe @a + +-- | Return an `Operations` value listing all the function applications necessary to +-- create a value of a given type +makeOperationsEither :: forall a ins out . (Typeable a) => Registry ins out -> Either Text Operations +makeOperationsEither registry = + let values = _values registry + functions = _functions registry + specializations = _specializations registry + modifiers = _modifiers registry + targetType = someTypeRep (Proxy :: Proxy a) + in + -- use the makeUntyped function to create an element of the target type from a list of values and functions + -- the list of values is kept as some State so that newly created values can be added to the current state + case + (flip evalStack) values + (makeUntyped targetType (Context [targetType]) functions specializations modifiers) + + of + Left e -> + Left $ "could not create a " <> show targetType <> " out of the registry because " <> e <> "\nThe registry is\n" <> + show registry + + other -> + other + +-- | Return an `Operations` value listing all the function applications necessary to +-- create a value of a given type (and throws an exception if the value cannot be created) +makeOperationsUnsafe :: forall a ins out . (Typeable a) => Registry ins out -> Operations +makeOperationsUnsafe registry = + case makeOperationsEither @a registry of + Right a -> a + Left e -> Prelude.error (toS e) diff --git a/src/Data/Registry/Internal/Cache.hs b/src/Data/Registry/Internal/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Internal/Cache.hs @@ -0,0 +1,37 @@ +{- | + + Cache for individual IO values when we wish to make singletons + for database connection pools for example + + This is inspired by https://hackage.haskell.org/package/io-memoize + +-} +module Data.Registry.Internal.Cache where + +import Data.Typeable (Typeable) +import Protolude as P + +-- | A thread-safe write-once cache. If you need more functionality, +-- (e.g. multiple write, cache clearing) use an 'MVar' instead. +newtype Cache a = Cache (MVar (Maybe a)) + deriving (Eq, Typeable) + +-- | Fetch the value stored in the cache, +-- or call the supplied fallback and store the result, +-- if the cache is empty. +fetch :: forall a m . (MonadIO m) => Cache a -> m a -> m a +fetch (Cache var) action = + do m <- liftIO $ P.readMVar var + case m of + Just a -> pure a + + Nothing -> do + val <- action + liftIO $ modifyMVar_ var (\_ -> pure (Just val)) + pure val + +-- | Create an empty cache. +newCache :: IO (Cache a) +newCache = do + var <- P.newMVar Nothing + return (Cache var) diff --git a/src/Data/Registry/Internal/Dynamic.hs b/src/Data/Registry/Internal/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Internal/Dynamic.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +{- | + Utility functions to work with Dynamic values +-} +module Data.Registry.Internal.Dynamic where + +import Data.Dynamic +import Data.Registry.Internal.Types +import Data.Text +import Protolude +import Type.Reflection + +-- | Apply a function to a list of Dynamic values +applyFunction :: + Function -- function + -> [Value] -- inputs + -> Either Text Value -- result +applyFunction function values = + do created <- applyFunctionDyn (funDyn function) (valueDyn <$> values) + pure $ CreatedValue created (ValueDescription (_outputType . funDescription $ function) Nothing) + +-- | Apply a Dynamic function to a list of Dynamic values +applyFunctionDyn + :: Dynamic -- function + -> [Dynamic] -- inputs + -> Either Text Dynamic -- result +applyFunctionDyn f [] = + Left $ "the function " + <> show (dynTypeRep f) + <> " cannot be applied to an empty list of parameters" +applyFunctionDyn f [i ] = applyOneParam f i +applyFunctionDyn f (i : is) = do + f' <- applyOneParam f i + applyFunctionDyn f' is + +-- | Apply just one dynamic parameter to a dynamic function +applyOneParam :: Dynamic -> Dynamic -> Either Text Dynamic +applyOneParam f i = + maybe (Left $ "failed to apply " <> show i <> " to : " <> show f) Right (dynApply f i) + +-- | If Dynamic is a function collect all its input types +collectInputTypes :: Function -> [SomeTypeRep] +collectInputTypes = go . funDynTypeRep + where + go :: SomeTypeRep -> [SomeTypeRep] + go (SomeTypeRep (Fun in1 out)) = SomeTypeRep in1 : go (SomeTypeRep out) + go _ = [] + +-- | If the input type is a function type return its output type +outputType :: SomeTypeRep -> SomeTypeRep +outputType (SomeTypeRep (Fun _ out)) = outputType (SomeTypeRep out) +outputType r = r diff --git a/src/Data/Registry/Internal/Make.hs b/src/Data/Registry/Internal/Make.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Internal/Make.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | + Untyped implementation of the functionalities in + Data.Registry.Make +-} +module Data.Registry.Internal.Make where + +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.Text as T (unlines) +import Protolude as P hiding (Constructor) +import Type.Reflection + +-- * WARNING: HIGHLY UNTYPED IMPLEMENTATION ! + +-- | Make a value from a desired output type represented by SomeTypeRep +-- and a list of possible constructors +-- A context is passed in the form of a stack of the types we are trying to build so far +-- We keep as a State value o +makeUntyped + :: SomeTypeRep + -> Context + -> Functions + -> Specializations + -> Modifiers + -> Stack (Maybe Value) +makeUntyped targetType context functions specializations modifiers = do + values <- getValues + + -- is there already a value with the desired type? + case findValue targetType context specializations values of + 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) + + Just function -> do + let inputTypes = collectInputTypes function + inputs <- makeInputs inputTypes context functions specializations modifiers + + if length inputs /= length inputTypes + then + let madeInputTypes = fmap valueDynTypeRep inputs + missingInputTypes = inputTypes \\ madeInputTypes + in + lift $ Left $ + unlines + $ ["could not make all the inputs for ", show (funDescription function), ". Only "] + <> (show <$> inputs) + <> ["could be made. Missing"] + <> fmap show missingInputTypes + else do + v <- lift $ applyFunction function inputs + modified <- storeValue modifiers v + + functionApplied modified inputs + pure (Just modified) + + + Just v -> do + modified <- storeValue modifiers v + pure (Just modified) + +-- | 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 + -> 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 (i : ins) (Context context) functions specializations modifiers = + if i `elem` context + then + lift $ Left + $ toS + $ unlines + $ ["cycle detected! The current types being built are "] + <> (show <$> context) + <> ["But we are trying to build again " <> show i] + else do + madeInput <- makeUntyped i (Context (i : 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 + + Just v -> do + (v :) <$> makeInputs ins (Context context) functions specializations modifiers diff --git a/src/Data/Registry/Internal/Operations.hs b/src/Data/Registry/Internal/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Internal/Operations.hs @@ -0,0 +1,71 @@ +{- | + Nested datatype to track the resolution algorithm + + From this data type we can draw a graph of the full + instantation of a value +-} +module Data.Registry.Internal.Operations where + +import Data.Registry.Internal.Types +import Data.Text as T +import Protolude + +-- | A list of function applications created +-- when creating a value out of the Registry +type Operations = [AppliedFunction] + +-- | A function application with an output value and a list of input values +data AppliedFunction = AppliedFunction { + _outputValue :: Value + , _inputValues ::[Value] + } deriving (Show) + +-- | Make a list of graph edges from the list of function applications +makeEdges :: Operations -> [(Value, Value)] +makeEdges [] = [] +makeEdges (AppliedFunction out ins : rest) = + ((out,) <$> ins) <> + makeEdges rest + +-- | A DOT graph +newtype Dot = Dot { + unDot :: Text + } deriving (Eq, Show) + +-- | Make a DOT graph out of all the function applications +toDot :: Operations -> Dot +toDot op = Dot $ T.unlines $ + [ "strict digraph {" + , " node [shape=record]" + ] + <> (toDotEdge <$> makeEdges op) + <> ["}"] + +-- | A DOT edge representing the dependency between 2 values +toDotEdge :: (Value, Value) -> Text +toDotEdge (v1, v2) = + adjust (nodeDescription . valDescription $ v1) + <> " -> " + <> adjust (nodeDescription . valDescription $ v2) + <> ";" + +-- | Description of a Value in the DOT graph +nodeDescription :: ValueDescription -> Text +nodeDescription (ValueDescription t Nothing) = t +nodeDescription (ValueDescription t (Just v)) = t <> "\n" <> v + +-- | We need to process the node descriptions +-- - we add quotes arountd the text +-- - we remove quotes (") inside the text +-- - we escape newlines +adjust :: Text -> Text +adjust t = "\"" <> (escapeNewlines . removeQuotes) t <> "\"" + +-- | Remove quotes from a textual description to avoid breaking the DOT format +removeQuotes :: Text -> Text +removeQuotes = T.replace "\"" "" + +-- | Replace \n with \\n so that newlines are kept in +-- node descriptions +escapeNewlines :: Text -> Text +escapeNewlines = T.replace "\n" "\\n" diff --git a/src/Data/Registry/Internal/Reflection.hs b/src/Data/Registry/Internal/Reflection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Internal/Reflection.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeInType #-} + +{- | + Utility functions to display types +-} +module Data.Registry.Internal.Reflection where + +import Data.Semigroup +import Data.Text as T +import Protolude as P hiding (intercalate, TypeRep, isPrefixOf, (<>)) +import Type.Reflection +import GHC.Exts + +-- | Return true if the type of this type rep represents a function +isFunction :: SomeTypeRep -> Bool +isFunction d = + case d of + SomeTypeRep (Fun _ _) -> True + _ -> False + +-- | Show the full type of a typeable value +showFullValueType :: Typeable a => a -> Text +showFullValueType = showTheFullValueType . typeOf + +-- | Show the full type of a typeable function +showFullFunctionType :: Typeable a => a -> ([Text], Text) +showFullFunctionType = showTheFullFunctionType . typeOf + +-- | Show the full type of a typeable value +-- where nested types like IO[Int] or functions are represented and +-- non GHC types are shown with their module names +showTheFullValueType :: forall (r1 :: RuntimeRep) (arg :: TYPE r1) . (TypeRep arg -> Text) +showTheFullValueType a = + case a of + Fun t1 t2 -> + showTheFullValueType t1 <> " -> " <> showTheFullValueType t2 + + Fun (App t1 t2) t3 -> + showNested (SomeTypeRep t1) (SomeTypeRep t2) <> " -> " <> showTheFullValueType t3 + + App t1 t2 -> + showNested (SomeTypeRep t1) (SomeTypeRep t2) + + _ -> + showSingleType (SomeTypeRep a) + +-- | Show the full type of a typeable value +-- where nested types like IO[Int] or functions are represented and +-- non GHC types are shown with their module names +showTheFullFunctionType :: forall (r1 :: RuntimeRep) (arg :: TYPE r1) . (TypeRep arg -> ([Text], Text)) +showTheFullFunctionType a = + case a of + Fun t1 t2 -> + let in1 = showTheFullValueType t1 + (ins, out) = showTheFullFunctionType t2 + in (in1 : ins, out) + + Fun (App t1 t2) t3 -> + let (ins, out) = showTheFullFunctionType t3 + in (showNested (SomeTypeRep t1) (SomeTypeRep t2) : ins, out) + + App t1 t2 -> + ([], showNested (SomeTypeRep t1) (SomeTypeRep t2)) + + _ -> + ([], showSingleType (SomeTypeRep a)) + +-- | Show a type like m a +showNested :: SomeTypeRep -> SomeTypeRep -> Text +showNested a b = + parenthesizeNested $ tweakNested $ showSingleType a <> " " <> showSingleType b + +-- | Show a single type. Don't display the module for GHC types +showSingleType :: SomeTypeRep -> Text +showSingleType a = + let withModuleName = showWithModuleName a + in if mustShowModuleName withModuleName + then withModuleName + else show a + +-- | Return true if the module name can be shown +mustShowModuleName :: Text -> Bool +mustShowModuleName name = not $ P.any identity $ + fmap (`isPrefixOf` name) [ + "GHC.Types." -- for Int, Double,.. + , "GHC.Base." -- for Maybe + , "Data.Either." -- for Either + , "Data.Text.Internal"] + +-- | Tweak some standard module names for better display +tweakNested :: Text -> Text +tweakNested "[] Char" = "String" +tweakNested n = + if "[] " `isPrefixOf` n then + "[" <> T.drop 3 n <> "]" -- special processing for lists + else + n + +-- | This is an attempt to better render "nested" types like IO (Maybe Text) +-- The input value is "IO Maybe Text" and the output text will be "IO (Maybe Text)" +-- This will unfortunately not work with types having several type parameters +-- like IO (Either Text Int) +parenthesizeNested :: Text -> Text +parenthesizeNested t = + case T.splitOn " " t of + [] -> t + [_] -> t + [outer, inner] -> outer <> " " <> inner + outer : rest -> outer <> " (" <> parenthesizeNested (T.intercalate " " rest) <> ")" + +-- | Show a type with its module name +showWithModuleName :: SomeTypeRep -> Text +showWithModuleName t = (toS . tyConModule . someTypeRepTyCon $ t) <> "." <> show t diff --git a/src/Data/Registry/Internal/Registry.hs b/src/Data/Registry/Internal/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Internal/Registry.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | + Internal structure of a registry and + associated functions +-} +module Data.Registry.Internal.Registry where + +import Data.Registry.Internal.Dynamic +import Data.Registry.Internal.Types +import Data.Registry.Internal.Stack +import Protolude as P +import Type.Reflection + +-- | Find a value having a target type +-- from a list of dynamic values found in a list of constructors +-- where some of them are not functions +-- There is also a list of specializations when we can specialize the values to use +-- if a given type is part of the context +findValue + :: SomeTypeRep + -> Context + -> Specializations + -> Values + -> Maybe Value +-- no specializations or constructors to choose from +findValue _ _ (Specializations []) (Values []) = Nothing + +-- recurse on the specializations first +findValue target (Context context) (Specializations ((t, v) : rest)) values = + -- if there is an override which value matches the current target + -- and if that override is in the current context then return the value + if target == valueDynTypeRep v && t `elem` context then + Just v + else + findValue target (Context context) (Specializations rest) values + +-- otherwise recurse on the list of constructors until a value +-- with the target type is found +findValue target context specializations (Values (v : rest)) = + if valueDynTypeRep v == target then + Just v + else + findValue target context specializations (Values rest) + +-- | Find a constructor function returning a target type +-- from a list of constructorsfe +findConstructor + :: SomeTypeRep + -> Functions + -> Maybe Function +findConstructor _ (Functions [] ) = Nothing +findConstructor target (Functions (f : rest)) = + case funDynTypeRep f of + SomeTypeRep (Fun _ out) -> + if outputType (SomeTypeRep out) == target then + Just f + else + findConstructor target (Functions rest) + + _ -> + findConstructor target (Functions rest) + +-- | Given a newly built value, check if there are modifiers for that +-- value and apply them before "storing" the value which means +-- adding it on top of the registry, represented by the `Values` state +-- in StateT Values. +-- We use a StateT Either because applying modifiers could fail and we want +-- to catch and report the error. Note that this error would be an implementation +-- error (and not a user error) since at the type-level everything should be correct +-- +storeValue + :: Modifiers + -> Value + -> Stack Value +storeValue (Modifiers ms) value = + let modifiers = findModifiers ms + + in do valueToStore <- modifyValue value modifiers + modifyValues (addValue valueToStore) + pure valueToStore + where + -- find the applicable modifiers + findModifiers = filter (\(m, _) -> valueDynTypeRep value == m) + + -- apply a list of modifiers to a value + modifyValue :: Value -> [(SomeTypeRep, Function)] -> Stack Value + modifyValue v [] = pure v + modifyValue v ((_, f) : rest) = do + applied <- lift $ applyFunction f [v] + modifyValue applied rest diff --git a/src/Data/Registry/Internal/Stack.hs b/src/Data/Registry/Internal/Stack.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Internal/Stack.hs @@ -0,0 +1,49 @@ +{- | + Internal monad for the resolution algorithm + + - we keep some state for the list of created values + - we collect the applied functions as "Operations" + - we might exit with a Left value if we can't build a value + +-} +module Data.Registry.Internal.Stack where + +import Data.Registry.Internal.Operations +import Data.Registry.Internal.Types +import Protolude + +-- | Monadic stack for the resolution algorithm +type Stack a = StateT (Values, Operations) (Either Text) a + +-- | Return a value from the Stack if possible +runStack :: Stack a -> Values -> Either Text a +runStack sa vs = evalStateT sa (vs, []) + +-- | Return the state of the stack after executing the action +-- This returns the list of built values +execStack :: Stack a -> Values -> Either Text Values +execStack sa vs = fst <$> execStateT sa (vs, []) + +-- | Return the list of applied functions after resolution +evalStack :: Stack a -> Values -> Either Text Operations +evalStack sa vs = snd <$> execStateT sa (vs, []) + +-- | Get the current list of values +getValues :: Stack Values +getValues = fst <$> get + +-- | Get the current list of operations +getOperation :: Stack Operations +getOperation = snd <$> get + +-- | Modify the current list of values +modifyValues :: (Values -> Values) -> Stack () +modifyValues f = modify (\(vs, ops) -> (f vs, ops)) + +-- | Get the current list of values +modifyOperations :: (Operations -> Operations) -> Stack () +modifyOperations f = modify (\(vs, ops) -> (vs, f ops)) + +-- | Store a function application in the list of operations +functionApplied :: Value -> [Value] -> Stack () +functionApplied output inputs = modifyOperations (AppliedFunction output inputs:) diff --git a/src/Data/Registry/Internal/Types.hs b/src/Data/Registry/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Internal/Types.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | + List of types used inside the Registry +-} +module Data.Registry.Internal.Types where + +import Data.Dynamic +import Data.Registry.Internal.Reflection +import Data.Text as T +import Prelude (show) +import Protolude hiding (show) +import Type.Reflection + +-- | A Function is the Dynamic representation of a Haskell value + its description +-- It is either provided by the user of the Registry or created as part of the +-- resolution algorithm +data Value = + CreatedValue Dynamic ValueDescription + | ProvidedValue Dynamic ValueDescription + deriving (Show) + +-- | Description of a value. It might just have +-- a description for its type when it is a value +-- created by the resolution algorithm +data ValueDescription = ValueDescription { + _valueType :: Text + , _valueValue :: Maybe Text + } deriving (Eq, Show) + +-- | Describe a value with its type and actual content +describeValue :: (Typeable a, Show a) => a -> ValueDescription +describeValue a = ValueDescription (showFullValueType a) (Just . toS $ show a) + +-- | Describe a value with only its type +describeTypeableValue :: (Typeable a) => a -> ValueDescription +describeTypeableValue a = ValueDescription (showFullValueType a) Nothing + +-- | Show a Value from the Registry +showValue :: Value -> Text +showValue = valDescriptionToText . valDescription + +-- | Create a Value from a Haskell value, with its Show description +createValue :: (Show a, Typeable a) => a -> Value +createValue a = ProvidedValue (toDyn a) (describeValue a) + +-- | Create a Value from a Haskell value, with only its Typeable description +createTypeableValue :: Typeable a => a -> Value +createTypeableValue a = ProvidedValue (toDyn a) (describeTypeableValue a) + +-- | Create a Value from a Dynamic value and some description +createDynValue :: Dynamic -> Text -> Value +createDynValue dyn desc = ProvidedValue dyn (ValueDescription desc Nothing) + +-- | Type representation of a Value +valueDynTypeRep :: Value -> SomeTypeRep +valueDynTypeRep (CreatedValue d _) = dynTypeRep d +valueDynTypeRep (ProvidedValue d _) = dynTypeRep d + +-- | Dynamic representation of a Value +valueDyn :: Value -> Dynamic +valueDyn (CreatedValue d _) = d +valueDyn (ProvidedValue d _) = d + +-- | The description for a Value +valDescription :: Value -> ValueDescription +valDescription (CreatedValue _ d) = d +valDescription (ProvidedValue _ d) = d + +-- | A ValueDescription as Text. If the actual content of the Value +-- is provided display the type first then the content +valDescriptionToText :: ValueDescription -> Text +valDescriptionToText (ValueDescription t Nothing) = t +valDescriptionToText (ValueDescription t (Just v)) = t <> ": " <> v + +-- | A Function is the Dynamic representation of a Haskell function + its description +data Function = Function Dynamic FunctionDescription deriving (Show) + +-- | Create a Function value from a Haskell function +createFunction :: (Typeable a) => a -> Function +createFunction a = + let dynType = toDyn a + in Function dynType (describeFunction a) + +-- | Description of a function with input types and output type +data FunctionDescription = FunctionDescription { + _inputTypes :: [Text] + , _outputType :: Text + } deriving (Eq, Show) + +-- | Describe a function (which doesn't have a Show instance) +-- that can be put in the Registry +describeFunction :: Typeable a => a -> FunctionDescription +describeFunction = uncurry FunctionDescription . showFullFunctionType + +-- | Show a Function as Text using its Description +showFunction :: Function -> Text +showFunction = funDescriptionToText . funDescription + +-- | The Description of a Function +funDescription :: Function -> FunctionDescription +funDescription (Function _ t) = t + +-- | Dynamic representation of a Function +funDyn :: Function -> Dynamic +funDyn (Function d _) = d + +-- | Type representation of a Function +funDynTypeRep :: Function -> SomeTypeRep +funDynTypeRep = dynTypeRep . funDyn + +-- | A FunctionDescription as Text +funDescriptionToText :: FunctionDescription -> Text +funDescriptionToText (FunctionDescription ins out) = T.intercalate " -> " (ins <> [out]) + +-- | Return True if a Function has some input values +hasParameters :: Function -> Bool +hasParameters = isFunction . funDynTypeRep + +-- | A Typed value can be added to a Registry +-- It is either a value, having both Show and Typeable information +-- or a function having just Typeable information +data Typed a = + TypedValue Value + | TypedFunction Function + +-- The list of functions available for constructing other values +newtype Functions = Functions [Function] deriving (Show, Semigroup, Monoid) + +-- | Add one more Function to the list of Functions +addFunction :: Function -> Functions -> Functions +addFunction f (Functions fs) = Functions (f : fs) + +-- | List of values available for constructing other values +newtype Values = Values [Value] deriving (Show, Semigroup, Monoid) + +-- | Add one more Value to the list of Values +addValue :: Value -> Values -> Values +addValue v (Values vs) = Values (v : vs) + +-- | The types of values being currently built +newtype Context = Context { _context :: [SomeTypeRep] } deriving (Show, Semigroup, Monoid) + +-- | Specification of values which become available for +-- construction when a corresponding type comes in context +newtype Specializations = Specializations [(SomeTypeRep, Value)] deriving (Show, Semigroup, Monoid) + +-- | List of functions modifying some values right after they have been +-- built. This enables "tweaking" the creation process with slightly +-- different results. Here SomeTypeRep is the target value type 'a' and +newtype Modifiers = Modifiers [(SomeTypeRep, Function)] deriving (Show, Semigroup, Monoid) diff --git a/src/Data/Registry/Lift.hs b/src/Data/Registry/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Lift.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | + This code is taken from https://stackoverflow.com/questions/28003135/is-it-possible-to-encode-a-generic-lift-function-in-haskell + to allow a generic lift operation over an Applicative context + So if you have a function: Int -> Text -> IO Int, it can be lifted to have all of its parameters + in IO: + + f :: Int -> Text -> IO Int + + lifted :: IO Int -> IO Text -> IO Int + lifted = to @IO f + +-} +module Data.Registry.Lift where + +import Protolude + +-- | Typeclass for lifting pure functions to effectful arguments and results +class Applicative f => ApplyVariadic f a b where + applyVariadic :: f a -> b + +instance (Applicative f, b ~ f a) => ApplyVariadic f a b where + applyVariadic = identity + +instance (Applicative f, ApplyVariadic f a' b', b ~ (f a -> b')) => ApplyVariadic f (a -> a') b where + applyVariadic f fa = applyVariadic (f <*> fa) + +-- | Lift a pure function to effectful arguments and results +allTo :: forall f a b. ApplyVariadic f a b => a -> b +allTo a = (applyVariadic :: f a -> b) (pure a) + +-- | Typeclass for lifting impure functions to effectful arguments and results +class Monad f => ApplyVariadic1 f a b where + applyVariadic1 :: f a -> b + +instance (Monad f, b ~ f a) => ApplyVariadic1 f (f a) b where + applyVariadic1 = join + +instance (Monad f, ApplyVariadic1 f a' b', b ~ (f a -> b')) => ApplyVariadic1 f (a -> a') b where + applyVariadic1 f fa = applyVariadic1 (f <*> fa) + +-- | Lift an effectful function to effectful arguments and results +argsTo :: forall f a b . ApplyVariadic1 f a b => a -> b +argsTo a = (applyVariadic1 :: f a -> b) (pure a) + +-- | Typeclass for lifting a function with a result of type m b into a function +-- with a result of type n b +class Applicative f => ApplyVariadic2 f g a b where + applyVariadic2 :: (forall x . f x -> g x) -> a -> b + +instance (Applicative f, b ~ g a) => ApplyVariadic2 f g (f a) b where + applyVariadic2 natfg = natfg + +instance (Applicative f, ApplyVariadic2 f g a' b', b ~ (a -> b')) => ApplyVariadic2 f g (a -> a') b where + applyVariadic2 natfg f a = applyVariadic2 natfg (f a) + +-- | Lift a function returning an effectful result to a function returning another effectful result +outTo :: forall g f a b . ApplyVariadic2 f g a b => (forall x . f x -> g x) -> a -> b +outTo natfg = applyVariadic2 natfg :: a -> b diff --git a/src/Data/Registry/Make.hs b/src/Data/Registry/Make.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Make.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | + This module provides functions to make values + out of a registry. The general algorithm is the following + + 1. for a given value type search in the existing list of values + a value with the same type. If found return it + + 2. if not found search a function having the desired output type + if found, now try to recursively make all the input parameters. + Keep a context of the current type trying to be built. + + 3. when trying to make an input parameter if the current input type + is already in the types trying to be built then there is a cycle. + Throw an exception in that case + + 4. when a value has been constructed place it on top of the existing value + list so that it can be reused by other functions + +-} +module Data.Registry.Make where + +import Data.Dynamic +import Data.Registry.Internal.Make +import Data.Registry.Internal.Stack +import Data.Registry.Internal.Types +import Data.Registry.Registry +import Data.Registry.Solver +import Data.Typeable (Typeable) +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 registry = + let values = _values registry + functions = _functions registry + specializations = _specializations registry + modifiers = _modifiers registry + targetType = someTypeRep (Proxy :: Proxy a) + in + -- use the makeUntyped function to create an element of the target type from a list of values and functions + -- the list of values is kept as some State so that newly created values can be added to the current state + case + (flip runStack) values $ + (makeUntyped targetType (Context [targetType]) functions specializations modifiers) + + of + Left e -> + Left $ "could not create a " <> show targetType <> " out of the registry because " <> e <> "\nThe registry is\n" <> + show registry + + Right Nothing -> + Left $ "could not create a " <> show targetType <> " out of the registry." <> "\nThe registry is\n" <> + show registry + + Right (Just result) -> fromMaybe + (Left $ "could not cast the computed value to a " <> show targetType <> ". The value is of type: " <> show (valueDynTypeRep result)) + (Right <$> fromDynamic (valueDyn result)) + +-- | 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 = + case makeEither registry of + Right a -> a + Left e -> Prelude.error (toS e) diff --git a/src/Data/Registry/RIO.hs b/src/Data/Registry/RIO.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/RIO.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE UndecidableInstances #-} +{- | + + RIO is equivalent to ResourceT (WriterT Warmup IO) + It can be used to instantiate "modules as records of functions" + where each module can allocate resources and have a "warmup phase" + to preload data or asses if it is working properly + +-} +module Data.Registry.RIO where + +import Control.Monad.Base +import Control.Monad.Catch +import Control.Monad.Trans.Resource +import qualified Control.Monad.Trans.Resource as Resource (allocate) + +import Data.Registry.Make +import Data.Registry.Registry +import Data.Registry.Solver +import Data.Registry.Warmup +import Protolude + +-- | Data type encapsulating resource finalizers +newtype Stop = Stop InternalState + +-- | Run all finalizers +runStop :: Stop -> IO () +runStop (Stop is) = runResourceT $ closeInternalState is + +-- | This newtype creates a monad to sequence +-- module creation actions, cumulating start/stop tasks +-- found along the way +newtype RIO a = + RIO + { runRIO :: Stop -> IO (a, Warmup) } + deriving (Functor) + +instance Applicative RIO where + pure a = + RIO (const (pure (a, mempty))) + + RIO fab <*> RIO fa = + RIO $ \s -> + do (f, sf) <- fab s + (a, sa) <- fa s + pure (f a, sf `mappend` sa) + +instance Monad RIO where + return = pure + + RIO ma >>= f = + RIO $ \s -> + do (a, sa) <- ma s + (b, sb) <- runRIO (f a) s + pure (b, sa `mappend` sb) + +instance MonadIO RIO where + liftIO io = RIO (const $ (, mempty) <$> io) + +instance MonadThrow RIO where + throwM e = RIO (const $ throwM e) + +instance MonadBase IO RIO where + liftBase = liftIO + +instance MonadResource RIO where + liftResourceT action = RIO $ \(Stop s) -> liftIO ((, mempty) <$> runInternalState action s) + +-- * For production + +-- | This function must be used to run services involving a top module +-- It creates the top module and invokes all warmup functions +-- +-- The passed function 'f' is used to decide whether to continue or +-- not depending on the Result +withRegistry :: forall a b ins out . (Typeable a, Contains (RIO a) out, Solvable ins out) => + Registry ins out + -> (Result -> a -> IO b) + -> IO b +withRegistry registry f = runResourceT $ do + (a, warmup) <- runRegistryT @a registry + result <- lift $ runWarmup warmup + lift $ f result a + +-- | This can be used if you want to insert the component creation inside +-- another action managed with ResourceT. Or if you want to call runResourceT yourself later +runRegistryT :: forall a ins out . (Typeable a, Contains (RIO a) out, Solvable ins out) => Registry ins out -> ResourceT IO (a, Warmup) +runRegistryT registry = withInternalState $ \is -> runRIO (make @(RIO a) registry) (Stop is) + +-- * For testing + +-- | Instantiate the component but don't execute the warmup (it may take time) +-- and keep the Stop value to clean resources later +-- This function statically checks that the component can be instantiated +executeRegistry :: forall a ins out . (Typeable a, Contains (RIO a) out, Solvable ins out) => Registry ins out -> IO (a, Warmup, Stop) +executeRegistry registry = do + is <- createInternalState + (a, w) <- runRIO (make @(RIO a) registry) (Stop is) + pure (a, w, Stop is) + +-- | Instantiate the component but don't execute the warmup (it may take time) and lose a way to cleanu up resources +-- | Almost no compilation time is spent on checking that component resolution is possible +unsafeRun :: forall a ins out . (Typeable a, Contains (RIO a) out) => Registry ins out -> IO a +unsafeRun registry = fst <$> unsafeRunWithStop registry + +-- | Same as unsafeRun but keep the Stop value to be able to clean resources later +unsafeRunWithStop :: forall a ins out . (Typeable a, Contains (RIO a) out) => Registry ins out -> IO (a, Stop) +unsafeRunWithStop registry = do + is <- createInternalState + (a, _) <- runRIO (makeUnsafe @(RIO a) registry) (Stop is) + pure (a, Stop is) + +-- * Module creation + +-- | Lift a warmup action into the RIO monad +warmupWith :: Warmup -> RIO () +warmupWith w = RIO (const $ pure ((), w)) + +-- | Allocate some resource +allocate :: IO a -> (a -> IO ()) -> RIO a +allocate resource cleanup = + snd <$> Resource.allocate resource cleanup diff --git a/src/Data/Registry/Registry.hs b/src/Data/Registry/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Registry.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | + A registry supports the creation of values out of existing values and + functions. + + It contains 4 parts: + - values: they are available for building anything else and have their exact value can be shown + - functions: they are used to build other values. Only their type can be shown + - specializations: description of specific values to use while trying to build another value of a given type + - modifiers: function to apply to a newly built value before storing it for future use + + A registry is created by using the +: operator, adding functions or values to the empty `end` registry: + + registry = + val (Config 1) + +: val "hello" + +: fun add1 + +: fun show1 + +: end + + 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. + + Registries have a `Monoid` instance so they can be created incrementally: + + config = + val (Config 1) + +: val "hello" + +: end + + constructors = + +: fun add1 + +: fun show1 + +: end + + registry = + config <> constructors + + It is also possible to use the `<>` operator to "override" some configurations: + + mocks = + fun noLogging + +: fun inMemoryDb + +: end + + mocks <> registry + +-} +module Data.Registry.Registry where + +import Data.Registry.Internal.Cache +import Data.Registry.Internal.Types +import Data.Registry.Lift +import Data.Registry.Solver +import Data.Dynamic +import Data.Semigroup ((<>)) +import Data.Text as T (unlines) +import Data.Typeable (Typeable) +import qualified Prelude (show) +import Protolude as P hiding ((<>)) +import Type.Reflection + +-- | Container for a list of functions or values +-- Internally all functions and values are stored as Dynamic values +-- so that we can access their representation +data Registry (inputs :: [*]) (outputs :: [*]) = + Registry { + _values :: Values + , _functions :: Functions + , _specializations :: Specializations + , _modifiers :: Modifiers + } + +instance Show (Registry inputs outputs) where + show (Registry (Values vs) (Functions fs) _ _) = + let describeValues = + if null vs then "" + else unlines (valDescriptionToText . valDescription <$> vs) + describeFunctions = + if null fs then "" + else unlines (funDescriptionToText . funDescription <$> fs) + in + toS $ unlines [describeValues, describeFunctions] + +instance Semigroup (Registry inputs outputs) => Monoid (Registry inputs outputs) where + mempty = Registry (Values []) (Functions []) (Specializations []) (Modifiers []) + mappend = (<>) + +-- | Append 2 registries together +(<+>) :: Registry is1 os1 -> Registry is2 os2 -> Registry (is1 :++ is2) (os1 :++ os2) +(<+>) (Registry (Values vs1) (Functions fs1) (Specializations ss1) (Modifiers ms1)) + (Registry (Values vs2) (Functions fs2) (Specializations ss2) (Modifiers ms2)) = + Registry (Values (vs1 <> vs2)) (Functions (fs1 <> fs2)) (Specializations (ss1 <> ss2)) (Modifiers (ms1 <> ms2)) + +-- | Store an element in the registry +-- Internally elements are stored as dynamic values +register :: (Typeable a) + => Typed a + -> Registry ins out + -> Registry (Inputs a :++ ins) (Output a ': out) +register (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) = + if hasParameters f then + Registry (Values vs) (Functions (f : fs)) specializations modifiers + else + Registry (Values (createDynValue (funDyn f) (showFunction f) : vs)) (Functions fs) specializations modifiers + +-- | Add an element to the Registry - Alternative to register where the parentheses can be ommitted +infixr 5 +: +(+:) :: (Typeable a) => Typed a -> Registry ins out -> Registry (Inputs a :++ ins) (Output a ': out) +(+:) = register + +-- | The empty Registry +end :: Registry '[] '[] +end = Registry (Values []) (Functions []) (Specializations []) (Modifiers []) + +-- | Create a value which can be added to the Registry +val :: (Typeable a, Show a) => a -> Typed a +val a = TypedValue (ProvidedValue (toDyn a) (describeValue a)) + +-- | Create a value which can be added to the Registry and "lift" it to an Applicative context +valTo :: forall m a . (Applicative m, Typeable a, Typeable (m a), Show a) => a -> Typed (m a) +valTo a = TypedValue (liftProvidedValue @m a) + +-- | Create a "lifted" a Value +liftProvidedValue :: forall m a . (Applicative m, Typeable a, Typeable (m a), Show a) => a -> Value +liftProvidedValue a = ProvidedValue (toDyn (pure a :: m a)) (describeValue a) + +-- | Create a function which can be added to the Registry +fun :: (Typeable a) => a -> Typed a +fun a = TypedFunction (createFunction a) + +-- | This is a shortcut to (fun . allTo) where `allTo` lifts all the inputs and output +-- to an Applicative context +funTo :: forall m a b . (ApplyVariadic m a b, Typeable a, Typeable b) => a -> Typed b +funTo a = fun (allTo @m a) + +-- | This is a shortcut to (fun . argsTo) where `allTo` lifts all the inputs +-- to an Applicative context +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 b (Registry values functions (Specializations c) modifiers) = Registry + values + functions + (Specializations ((someTypeRep (Proxy :: Proxy a), createTypeableValue b) : c)) + modifiers + +-- | 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 b (Registry values functions (Specializations c) modifiers) = Registry + values + functions + (Specializations ((someTypeRep (Proxy :: Proxy a), createValue b) : c)) + modifiers + +-- | This is similar to specialize but additionally uses the Show instance of b +-- to display more information when printing the registry out and +-- it "lifts" the value to an applicative context +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 b (Registry values functions (Specializations c) modifiers) = Registry + values + functions + (Specializations ((someTypeRep (Proxy :: Proxy a), liftProvidedValue @m b) : c)) + modifiers + +-- | Once a value has been computed allow to modify it before storing +-- it +tweak :: forall a ins out . (Typeable a, Contains a out) + => (a -> a) + -> Registry ins out + -> Registry ins out +tweak f (Registry values functions specializations (Modifiers mf)) = Registry values functions specializations + (Modifiers ((someTypeRep (Proxy :: Proxy a), createFunction f) : mf)) + +-- | Return singleton 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! +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 r = do + cache <- newCache @a + pure $ tweak @(m a) (fetch cache) r diff --git a/src/Data/Registry/Solver.hs b/src/Data/Registry/Solver.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Solver.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | + 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 + +import Data.Kind +import GHC.TypeLits + +-- | Compute the list of input types for a function +type family Inputs f :: [*] where + Inputs (i -> o) = i ': Inputs o + Inputs x = '[] + +-- | Compute the output type for a function +type family Output f :: * where + Output (i -> o) = Output o + Output x = x + +-- | Compute if a type is contained in a list of types +type family Contains (a :: *) (els :: [*]) :: Constraint where + Contains a '[] = TypeError ('Text "No element of type " ':<>: 'ShowType a ':<>: 'Text " can be build out of the registry") + Contains a (a ': els) = () + Contains a (b ': els) = Contains a els + +-- | 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 :: [*]) (out :: [*]) +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 :: [*]) (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: +type family (:++) (x :: [k]) (y :: [k]) :: [k] where + '[] :++ xs = xs + (x ': xs) :++ ys = x ': (xs :++ ys) diff --git a/src/Data/Registry/Warmup.hs b/src/Data/Registry/Warmup.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Warmup.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | + This module contains data structures to describe the + "warming-up" of componnts in order to ensure that they + are properly configured: + + - createWarmup creates a warmup from an action + returning a Result + + - warmupOf takes a component name and unit action + then just checks that the action executes without + exception +-} +module Data.Registry.Warmup where + +import qualified Control.Monad.Catch as Catch +import Data.Semigroup ((<>)) +import Protolude as P hiding ((<>)) +import Data.Typeable + +-- | A list of actions to run at startup +newtype Warmup = + Warmup + { _warmUp :: [IO Result] + } deriving (Monoid, Semigroup) + +-- * Creation functions + +-- | Create a warmup action for a given module +-- The type of the module is used as the description for +-- the action to execute +warmupOf :: Typeable a => a -> IO () -> Warmup +warmupOf a action = createWarmup $ + do res <- Catch.try action :: IO (Either SomeException ()) + pure $ + case res of + Left e -> failed $ "KO: " <> show (typeOf a) <> " -> " <> show e + Right _ -> ok $ "OK: " <> show (typeOf a) + +-- | Create a Warmup from an IO action returning a Result +createWarmup :: IO Result -> Warmup +createWarmup t = Warmup [t] + +-- | The empty Warmup +noWarmup :: Warmup +noWarmup = Warmup [pure Empty] + +-- | Create a warmup with no action but just the type of a component +declareWarmup :: Typeable a => a -> Warmup +declareWarmup a = warmupOf a (pure ()) + +-- | Result of a warmup +data Result = + Empty + | Ok [Text] + | Failed [Text] + deriving (Eq, Show) + +-- | Return True if a Warmup was successful +isSuccess :: Result -> Bool +isSuccess Empty = True +isSuccess (Ok _) = True +isSuccess (Failed _) = False + +-- | Create a successful Result +ok :: Text -> Result +ok t = Ok [t] + +-- | Create a failed Result +failed :: Text -> Result +failed t = Failed [t] + +-- | Extract the list of all the messages from a Result +messages :: Result -> [Text] +messages Empty = [] +messages (Ok ms) = ms +messages (Failed ms) = ms + +instance Monoid Result where + mempty = Empty + mappend = (<>) + +instance Semigroup Result where + r <> Empty = r + Empty <> r = r + Failed ts <> r = Failed (ts ++ messages r) + r <> Failed ts = Failed (messages r ++ ts) + Ok ts1 <> Ok ts2 = Ok (ts1 ++ ts2) + + +-- * Run functions + +-- | Simple sequential warmup strategy +runWarmup :: Warmup -> IO Result +runWarmup (Warmup as) = foldr' runBoth (pure Empty) as + +-- | runBoth runs both tasks and cumulate the results +-- exceptions are being transformed into Failed results +runBoth :: IO Result -> IO Result -> IO Result +runBoth io1 io2 = do + res1 <- Catch.try io1 :: IO (Either SomeException Result) + res2 <- Catch.try io2 :: IO (Either SomeException Result) + pure $ + case (res1, res2) of + (Right r1, Right r2) -> r1 `mappend` r2 + (Left r1, Right r2) -> failed (show r1) `mappend` r2 + (Right r1, Left r2) -> r1 `mappend` failed (show r2) + (Left r1, Left r2) -> Failed [show r1, show r2] diff --git a/test/Test/Data/Registry/DotSpec.hs b/test/Test/Data/Registry/DotSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/DotSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Test.Data.Registry.DotSpec where + +import Data.Registry.Dot +import Data.Registry +import Protolude +import Data.Text as T +import Test.Tasty.Extensions + +test_dot = + prop "a dot graph can be generated from a registry" $ do + let dot = makeDot @(IO Listener) registry + unDot dot === T.unlines [ + "strict digraph {" + ," node [shape=record]" + ,"\"IO Test.Data.Registry.DotSpec.Listener\" -> \"Test.Data.Registry.DotSpec.ListenerConfig\\nListenerConfig nyc\";" + ,"\"IO Test.Data.Registry.DotSpec.Listener\" -> \"IO Test.Data.Registry.DotSpec.Logging\";" + ,"}" + ] + + +-- * Helpers + +-- a registry + +config = + valTo @IO (AuthConfig "auth") + +: valTo @IO (ListenerConfig "nyc") + +: end + +registry = + fun newLogging + +: funTo @IO newAuth + +: funAs @IO newListener + +: config + +-- A small graph of components + +newtype Logging = Logging { info :: Text -> IO () } + +newLogging :: IO Logging +newLogging = pure (Logging print) + +newtype Auth = Auth { auth :: Text -> IO Bool } +newtype AuthConfig = AuthConfig Text deriving (Eq, Show) + +newAuth :: AuthConfig -> Logging -> Auth +newAuth _config _logging = Auth (\t -> print t >> pure True) + +newtype Listener = Listener { listen :: Text -> IO () } +newtype ListenerConfig = ListenerConfig Text deriving (Eq, Show) + +newListener :: ListenerConfig -> Logging -> IO Listener +newListener _config _logging = pure (Listener print) + +---- +tests = $(testGroupGenerator) diff --git a/test/Test/Data/Registry/Internal/CacheSpec.hs b/test/Test/Data/Registry/Internal/CacheSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Internal/CacheSpec.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Test.Data.Registry.Internal.CacheSpec where + +import Control.Concurrent.Async +import Data.IORef +import Data.Registry.Internal.Cache +import Protolude as P +import Test.Tasty.Extensions + +test_cache = test "caching an IO action must always return the same value" $ do + cached <- liftIO $ do + -- create an action which will increment an Int everytime it is called + ref <- newIORef (0 :: Int) + let action = modifyIORef ref (+1) >> readIORef ref + cache <- newCache + + -- when the action is cached it will always return the same value + let cachedAction = fetch cache action + _ <- replicateConcurrently_ 100 cachedAction -- with concurrent accesses + cachedAction + + cached === 1 + +---- +tests = $(testGroupGenerator) diff --git a/test/Test/Data/Registry/Internal/DynamicSpec.hs b/test/Test/Data/Registry/Internal/DynamicSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Internal/DynamicSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Test.Data.Registry.Internal.DynamicSpec where + +import Data.Dynamic +import Data.Text as T +import Data.Registry.Internal.Dynamic +import Data.Registry.Internal.Types +import Protolude as P +import Test.Tasty.Extensions +import Type.Reflection hiding (typeRep) + +test_collectInputTypes = test "we can collect the input types of a function" $ do + + collectInputTypes (createFunction (u :: Int)) === [] + collectInputTypes (createFunction (u :: Text -> Int)) === [dynType (u :: Text)] + collectInputTypes (createFunction (u :: Int -> Text -> Int)) === [dynType (u :: Int), dynType (u :: Text)] + collectInputTypes (createFunction (u :: Int -> Maybe Double -> Maybe Text)) === [dynType (u :: Int), dynType (u :: Maybe Double)] + +test_outputType = test "we can get the output type of a function" $ do + + outputType (dynType (u :: Int)) === dynType (u :: Int) + outputType (dynType (u :: Text -> Int)) === dynType (u :: Int) + outputType (dynType (u :: Int -> Text -> Int)) === dynType (u :: Int) + outputType (dynType (u :: Int -> Maybe Double -> Maybe Text)) === dynType (u :: Maybe Text) + +test_applyFunction = test "we can apply a list of dynamic values to a dynamic function" $ do + + (fromDynamic @Int . valueDyn <$> applyFunction (createFunction T.length) [createValue ("hello" :: Text)]) === Right (Just 5) + + let add1 (i::Int) (j::Int) = show (i + j) :: Text + (fromDynamic @Text . valueDyn <$> applyFunction (createFunction add1) [createValue (1 :: Int), createValue (2 :: Int)]) === Right (Just "3") + + -- no value is returned when an input parameter is incorrect + (fromDynamic @Int . valueDyn <$> applyFunction (createFunction T.length) [createValue (1 :: Int)]) === Left "failed to apply <> to : < Int>>" + + -- no value is returned when there are not enough inputs + (fromDynamic @Text . valueDyn <$> applyFunction (createFunction add1) []) === Left "the function Int -> Int -> Text cannot be applied to an empty list of parameters" + + +u = undefined + +dynType :: forall a . (Typeable a) => a -> SomeTypeRep +dynType = dynTypeRep . toDyn + +---- +tests = $(testGroupGenerator) diff --git a/test/Test/Data/Registry/Internal/Gens.hs b/test/Test/Data/Registry/Internal/Gens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Internal/Gens.hs @@ -0,0 +1,92 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Test.Data.Registry.Internal.Gens where + +import Data.Dynamic +import Data.Registry +import Data.Registry.Internal.Types +import Data.Text as T +import Hedgehog +import Hedgehog.Gen as Gen +import Hedgehog.Range as Range +import Prelude (show) +import Protolude +import Type.Reflection + +registry = + funTo @Gen UntypedRegistry + +: funTo @Gen Values + +: funTo @Gen Functions + +: funTo @Gen Specializations + +: funTo @Gen Modifiers + +: funTo @Gen Context + +: funTo @Gen Function + +: funTo @Gen ProvidedValue + +: funTo @Gen ValueDescription + +: funTo @Gen FunctionDescription + +: fun (genList @(SomeTypeRep, Function)) + +: fun (genList @(SomeTypeRep, Value)) + +: fun (genPair @SomeTypeRep @Function) + +: fun (genPair @SomeTypeRep @Value) + +: fun (genList @Function) + +: fun (genList @SomeTypeRep) + +: fun (genList @Value) + +: fun (genList @Function) + +: fun (genMaybe @Text) + +: fun (genList @Text) + +: fun genInt + +: fun genText + +: fun genTextToInt + +: fun genDynamic + +: fun genSomeTypeRep + +: end + +-- * generators +newtype TextToInt = TextToInt (Text -> Int) +instance Show TextToInt where show _ = "" +instance Eq TextToInt where _ == _ = True + +genTextToInt :: Gen TextToInt +genTextToInt = pure (TextToInt T.length) + +data UntypedRegistry = UntypedRegistry { + _uvalues :: Values + , _ufunctions :: Functions + , _uspecializations :: Specializations + , _umodifiers :: Modifiers + } deriving (Show) + +genValues :: Gen (Int, Values) +genValues = do + value <- gen @Int + values <- (createValue value `addValue`) <$> gen @Values + pure (value, values) + +genSomeTypeRep :: Gen Value -> Gen SomeTypeRep +genSomeTypeRep genValue = do + ProvidedValue a _ <- genValue + pure $ dynTypeRep a + +genDynamic :: Gen Dynamic +genDynamic = Gen.element [toDyn (1 :: Int), toDyn (2 :: Int), toDyn ("1" :: Text)] + +forall :: forall a . (Typeable a, Show a) => PropertyT IO a +forall = forAll $ makeUnsafe @(Gen a) registry + +genList :: forall a . Gen a -> Gen [a] +genList = Gen.list (Range.linear 1 3) + +genMaybe :: forall a . Gen a -> Gen (Maybe a) +genMaybe = Gen.maybe + +genPair :: forall a b . Gen a -> Gen b -> Gen (a, b) +genPair gena genb = (,) <$> gena <*> genb + +genInt :: Gen Int +genInt = Gen.int (Range.linear 0 5) + +gen :: forall a . (Typeable a) => Gen a +gen = makeUnsafe registry + +genText :: Gen Text +genText = Gen.text (Range.linear 2 10) Gen.alphaNum diff --git a/test/Test/Data/Registry/Internal/MakeSpec.hs b/test/Test/Data/Registry/Internal/MakeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Internal/MakeSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Test.Data.Registry.Internal.MakeSpec where + +import Data.Registry.Internal.Make +import Data.Registry.Internal.Types +import Data.Registry.Internal.Stack +import Data.Text as T +import Protolude as P +import Test.Data.Registry.Internal.Gens +import Test.Tasty.Extensions +import Type.Reflection + +test_make_inputs_with_cycle = prop "making inputs when there's a cycle must be detected" $ do + target <- forall @SomeTypeRep + context' <- forall @Context + functions <- forall @Functions + specializations <- forall @Specializations + modifiers <- forall @Modifiers + values <- forall @Values + + -- put one of the input types to build already in the list of + -- types being built + let context = Context (target : _context context') + + let result = runStack (makeInputs [target] context functions specializations modifiers) values + case result of + Left e -> annotateShow e >> "cycle detected!" `T.isPrefixOf` e === True + Right _ -> failure + + +---- +tests = $(testGroupGenerator) diff --git a/test/Test/Data/Registry/Internal/ReflectionSpec.hs b/test/Test/Data/Registry/Internal/ReflectionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Internal/ReflectionSpec.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Test.Data.Registry.Internal.ReflectionSpec where + +import Data.Dynamic +import Data.Registry.Internal.Types +import Data.Registry.Internal.Reflection +import Prelude (String) +import Protolude as P +import Test.Tasty.Extensions + +test_is_function = test "we can check if a type rep represents a function" $ do + + isFunction (dynTypeRep $ toDyn (u :: Int -> Int)) === True + isFunction (dynTypeRep $ toDyn (u :: Int -> IO Int)) === True + isFunction (dynTypeRep $ toDyn (u :: Int)) === False + isFunction (dynTypeRep $ toDyn (u :: IO Int)) === False + +test_show_value = test "show value for a simple type" $ do + valDescriptionToText (describeValue (1 :: Int) ) === "Int: 1" + valDescriptionToText (describeValue (1 :: Double) ) === "Double: 1.0" + valDescriptionToText (describeValue (True :: Bool)) === "Bool: True" + valDescriptionToText (describeValue ("1" :: Text) ) === "Text: \"1\"" + valDescriptionToText (describeValue ("1" :: String)) === "String: \"1\"" + +test_show_value_nested_type = test "show value for a nested types" $ do + valDescriptionToText (describeValue (Just 1 :: Maybe Int)) === "Maybe Int: Just 1" + + + -- putting parentheses around types doesn't really work when type constructors + -- have more than one argument :-( + valDescriptionToText (describeValue (Right 1 :: Either Text Int)) === "Either (Text Int): Right 1" + valDescriptionToText (describeValue ([1] :: [Int]) ) === "[Int]: [1]" + + -- user types must be shown with their full module names + valDescriptionToText (describeValue mod1) === "Test.Data.Registry.Internal.ReflectionSpec.Mod Int: Mod 1 \"hey\"" + +test_show_function = test "show simple functions" $ do + funDescriptionToText (describeFunction add1 ) === "Int -> Int" + funDescriptionToText (describeFunction add2 ) === "Int -> Int -> Text" + funDescriptionToText (describeFunction iomod) === "IO (Test.Data.Registry.Internal.ReflectionSpec.Mod Int)" + + funDescriptionToText (describeFunction fun0) === "IO Int" + funDescriptionToText (describeFunction fun1) === "IO Int -> IO Int" + funDescriptionToText (describeFunction fun2) === "IO Int -> IO Int -> IO Int" + funDescriptionToText (describeFunction fun3) === "IO (Test.Data.Registry.Internal.ReflectionSpec.Mod Int) -> IO Int" + +-- * helpers +u = undefined + +data Mod a = Mod a Text deriving (Eq, Show) + +mod1 :: Mod Int +mod1 = Mod 1 "hey" + +iomod :: IO (Mod Int) +iomod = pure (Mod 1 "hey") + +add1 :: Int -> Int +add1 i = i + 1 + +add2 :: Int -> Int -> Text +add2 _ = undefined + +fun0 :: IO Int +fun0 = undefined + +fun1 :: IO Int -> IO Int +fun1 = undefined + +fun2 :: IO Int -> IO Int -> IO Int +fun2 = undefined + +fun3 :: IO (Mod Int) -> IO Int +fun3 = undefined + +---- +tests = $(testGroupGenerator) diff --git a/test/Test/Data/Registry/Internal/RegistrySpec.hs b/test/Test/Data/Registry/Internal/RegistrySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Internal/RegistrySpec.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Test.Data.Registry.Internal.RegistrySpec where + +import Data.Dynamic +import Data.Registry.Internal.Types +import Data.Registry.Internal.Stack +import Data.Registry.Internal.Registry +import Protolude as P hiding (show) +import Test.Data.Registry.Internal.Gens +import Test.Tasty.Extensions + +test_find_no_value = prop "no value can be found if nothing is stored in the registry" $ do + value <- forAll $ gen @Int + + (fromValueDyn <$> findValue (valueDynTypeRep (createValue value)) mempty mempty mempty) === (Nothing :: Maybe (Maybe Int)) + +test_find_value = prop "find a value in a list of values when there are no specializations" $ do + (value, values) <- forAll genValues + + (fromValueDyn <$> findValue (valueDynTypeRep (createValue value)) mempty mempty values) === Just (Just value) + +test_find_specialized_value = prop "find a value in a list of values when there is a specialization for a given context" $ do + value <- forAll $ gen @Int + values <- forAll $ gen @Values + let listTypeRep = dynTypeRep . toDyn $ [value] + let context = Context [listTypeRep] -- when trying to build a [Int] + let specializations = Specializations [(listTypeRep, createValue value)] + + (fromValueDyn <$> findValue (valueDynTypeRep (createValue value)) context specializations values) === Just (Just value) + +test_find_no_constructor = prop "no constructor can be found if nothing is stored in the registry" $ do + value <- forAll $ gen @Int + + (fromDynamic . funDyn <$> findConstructor (valueDynTypeRep (createValue value)) mempty) === (Nothing :: Maybe (Maybe Int)) + +test_find_contructor = prop "find a constructor in a list of constructors" $ do + (TextToInt function) <- forAll $ gen @TextToInt + functions <- forAll $ (createFunction function `addFunction`) <$> gen @Functions + + let outputType = dynTypeRep (toDyn (1 :: Int)) + + (fmap TextToInt <$> (fromDynamic . funDyn <$> findConstructor outputType functions)) === + Just (Just (TextToInt function)) + +test_store_value_no_modifiers = prop "a value can be stored in the list of values" $ do + (value, values) <- forAll genValues + + let createdValue = createValue value + let (Right stored) = execStack (storeValue mempty createdValue) values + + let found = findValue (dynTypeRep . toDyn $ value) mempty mempty stored + (fromValueDyn <$> found) === Just (Just value) + +test_store_value_with_modifiers = prop "a value can be stored in the list of values but modified beforehand" $ do + (value, values) <- forAll genValues + + let valueType = dynTypeRep . toDyn $ value + let modifiers = Modifiers [(valueType, createFunction (\(i:: Int) -> i + 1))] + let createdValue = createValue value + let (Right stored) = execStack (storeValue modifiers createdValue) values + + let found = findValue valueType mempty mempty stored + (fromValueDyn <$> found) === Just (Just (value + 1)) + +test_store_value_ordered_modifiers = prop "modifiers are applied in a LIFO order" $ do + (value, values) <- forAll genValues + + let valueType = dynTypeRep . toDyn $ value + let modifiers = Modifiers [ + (valueType, createFunction (\(i:: Int) -> i * 2)) + , (valueType, createFunction (\(i:: Int) -> i + 1)) + ] + let createdValue = createValue value + let (Right stored) = execStack (storeValue modifiers createdValue) values + + let found = findValue valueType mempty mempty stored + (fromValueDyn <$> found) === Just (Just ((value * 2) + 1)) + +-- * + +fromValueDyn = fromDynamic . valueDyn + +---- +tests = $(testGroupGenerator) diff --git a/test/Test/Data/Registry/Make.hs b/test/Test/Data/Registry/Make.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Make.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +{- + This module tests the construction of some simple values + using a registry +-} +module Test.Data.Registry.Make where + +import Data.Registry +import Data.Text as T (length) +import Data.IORef +import Protolude hiding (C1) +import Test.Tasty.Extensions +import System.IO.Memoize + + +-- | Contextual setting of different values for a given type +test_contextual = test "values can use some values depending on some context" $ do + (c1, c2) <- liftIO $ + do let r = val (Config 3) + +: fun newUseConfig1 + +: fun newUseConfig2 + +: end + let r' = specialize @UseConfig1 (Config 1) $ + specialize @UseConfig2 (Config 2) $ r + pure (printConfig1 (make @UseConfig1 r'), printConfig2 (make @UseConfig2 r')) + + c1 === Config 1 + c2 === Config 2 + +newtype Config = Config Int deriving (Eq, Show) + +newtype UseConfig1 = UseConfig1 { printConfig1 :: Config } +newUseConfig1 config = UseConfig1 { printConfig1 = config } + +newtype UseConfig2 = UseConfig2 { printConfig2 :: Config } +newUseConfig2 config = UseConfig2 { printConfig2 = config } + +-- | 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) + +: fun newUseConfig1 + +: fun newAppUsingConfig1 + +: end + let r' = tweak (\(UseConfig1 _) -> UseConfig1 (Config 10)) r + pure (printConfig (make @AppUsingConfig1 r')) + + c1 === Config 10 + +newtype AppUsingConfig1 = AppUsingConfig1 { printConfig :: Config } +newAppUsingConfig1 config1 = AppUsingConfig1 { printConfig = printConfig1 config1 } + +-- | Creation of singletons with memoization +test_singleton = test "effectful values can be made as singletons with System.IO.Memoize" $ do + (c1, c2) <- liftIO $ + do -- create a counter for the number of instantiations + counter <- newIORef 0 + + newSingOnce <- once (newSing counter) + let r = fun (argsTo @IO newC1) + +: fun (argsTo @IO newC2) + +: fun (argsTo @IO newSingOnce) + +: end + c1 <- make @(IO C1) r + c2 <- make @(IO C2) r + pure (c1, c2) + + c1 === C1 (Sing 1) + c2 === C2 (Sing 1) + +test_singleton_proper = test "effectful values can be made as singletons" $ do + (c1, c2) <- liftIO $ + do -- create a counter for the number of instantiations + counter <- newIORef 0 + + let r = fun (argsTo @IO newC1) + +: fun (argsTo @IO newC2) + +: fun (argsTo @IO (newSing counter)) + +: end + r' <- singleton @IO @Sing r + c1 <- make @(IO C1) r' + c2 <- make @(IO C2) r' + pure (c1, c2) + + c1 === C1 (Sing 1) + c2 === C2 (Sing 1) + +newtype C1 = C1 Sing deriving (Eq, Show) +newC1 :: Sing -> IO C1 +newC1 = pure . C1 + +newtype C2 = C2 Sing deriving (Eq, Show) +newC2 :: Sing -> IO C2 +newC2 = pure . C2 + +newtype Sing = Sing Int deriving (Eq, Show) +newSing :: IORef Int -> IO Sing +newSing counter = do + _ <- modifyIORef counter (+1) + i <- readIORef counter + pure (Sing i) + +-- | Effectful creation with lifting +test_lifted = test "functions can be lifted in order to participate in building instances" $ do + f1 <- liftIO $ + do let r = fun (argsTo @IO newF1) + +: valTo @IO (1::Int) + +: valTo @IO ("hey"::Text) + +: end + make @(IO F1) r + + f1 === F1 1 "hey" + +data F1 = F1 Int Text deriving (Eq, Show) + +newF1 :: Int -> Text -> IO F1 +newF1 i t = pure (F1 i t) + +test_cycle = test "cycle can be detected" $ do + -- a registry with 2 functions inverse of each other + let explosive = makeUnsafe @Text (fun add1 +: fun dda1 +: end) + r <- liftIO $ try (print explosive) + case r of + Left (_ :: SomeException) -> assert True + Right _ -> assert False + +-- | A regular module can be made without having an explicit Typeable constraint +data LoggingModule = LoggingModule { + info :: Text -> IO () +, debug :: Text -> IO () +} + +loggingModule = make @LoggingModule (fun LoggingModule { info = print, debug = print } +: end) + +-- | Simple datatypes which can be used in a registry +newtype Text1 = Text1 Text deriving (Eq, Show) +newtype Text2 = Text2 Text deriving (Eq, Show) +newtype Int1 = Int1 Int deriving (Eq, Show) + +-- | values and functions +int1 :: Int +int1 = 1 + +add1 :: Int -> Text +add1 i = show (i + 1) + +add2 :: Int -> Text -> Text1 +add2 i j = Text1 (show (i+1) <> j) + +text1 :: Text +text1 = "text1" + +toText2 :: Text1 -> Text2 +toText2 (Text1 t) = Text2 t + +registry1 :: Registry (Inputs Int :++ '[Int, Int, Text, Text1]) + '[Output Int, Text, Text1, Text2] +registry1 = + val int1 + +: fun add1 + +: fun add2 + +: fun toText2 + +: end + +countSize :: Text -> Maybe Int +countSize t = Just (T.length t) + +m = make @Text $ (fun $ \(t::Text) -> t) +: end + +made1 :: Text +made1 = make @Text registry1 + +made2 :: Text1 +made2 = make @Text1 registry1 + +made3 :: Text2 +made3 = make @Text2 registry1 + +-- +countSize1 :: Text -> Int1 +countSize1 t = Int1 (T.length t) + +registry2 :: Registry (Inputs Int :++ '[Int, Text]) '[Output Int, Text, Int1] +registry2 = + fun int1 + +: fun add1 + +: fun countSize1 + +: end + +made4 :: Int1 +made4 = make @Int1 registry2 + +-- | This does *not* compile because Double in not in the +-- list of outputs for registry2 +{- +wrong :: Double +wrong = make @Double registry2 +-} + +-- | This does *not* compile because the list of inputs +-- in registry2 is not included in the list of outputs +unknown :: Double -> Text1 +unknown _ = Text1 "text1" + +registry3 :: Registry (Inputs Int :++ '[Double, Int, Text]) + '[Output Int, Text1, Text, Int1] +registry3 = + val int1 + +: fun unknown + +: fun add1 + +: fun countSize1 + +: end + +-- | 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 +-} + +-- | This version compiles but throws an exception at runtime +dangerous :: Text1 +dangerous = makeUnsafe @Text1 registry3 + +-- | This test shows that we can detect a cycle at runtime + +-- inverse of add1 +dda1 :: Text -> Int +dda1 = T.length + +---- +tests = $(testGroupGenerator) diff --git a/test/Test/Data/Registry/SmallExample.hs b/test/Test/Data/Registry/SmallExample.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/SmallExample.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +{- + This module tests the construction of some simple values + using a registry +-} +module Test.Data.Registry.SmallExample where + +import Data.Registry +import Data.Text (splitOn) +import Data.Typeable (Typeable) +import Protolude as P +import Test.Tasty.Extensions + +-- | Components of the application +newtype Logger = Logger { + info :: Text -> IO () +} deriving Typeable + +newLogger :: Logger +newLogger = Logger print + +noLogging = Logger (const (pure ())) + +newtype LinesCounter = LinesCounter { + count :: Text -> Int +} deriving Typeable + +newLinesCounter :: LinesCounter +newLinesCounter = LinesCounter $ \t -> length (splitOn "\n" t) + +newtype S3 = S3 { + store :: Text -> IO () +} deriving Typeable + +data S3Config = S3Config { + bucket :: Text +, key :: Text +} deriving (Eq, Show, Typeable) + +newS3 :: MonadIO m => S3Config -> Logger -> m S3 +newS3 config logger = pure $ S3 $ + \t -> (logger & info) ("storing on S3 with config " <> P.show config) >> + void (print t) -- send the text to s3 + +newtype Application = Application { + run :: Text -> IO Int +} deriving Typeable + +newApplication :: MonadIO m => Logger -> LinesCounter -> S3 -> m Application +newApplication logger counter s3 = pure $ Application $ \t -> do + (logger & info) "count lines" + let n = (counter & count) t + + (logger & info) "store the lines on s3" + (s3 & store) ("counted " <> P.show n <> " lines") + pure n + +-- | Create a registry for all constructors +registry = + funAs @IO (newS3 @IO) + +: funAs @IO (newApplication @IO) + +: funTo @IO newLogger + +: funTo @IO newLinesCounter + +: valTo @IO (S3Config "bucket" "key") + +: end + +-- | To create the application you call `make` for the `Application` type +-- with the registry above +-- 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) + +test_create = test "create the application" $ do + app <- liftIO $ createApplication -- nothing should crash! + r <- liftIO $ (app & run) "hello\nworld" + r === 2 + +---- +tests = $(testGroupGenerator) diff --git a/test/Test/Data/Registry/WarmupSpec.hs b/test/Test/Data/Registry/WarmupSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/WarmupSpec.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Test.Data.Registry.WarmupSpec where + +import Control.Monad.Catch +import Prelude (show) +import Protolude +import Test.Tasty.Extensions +import Data.Registry.Warmup + +test_runBoth1 = + prop "all results are collected when running 2 start/stop tasks" $ do + r1 <- forAll genResult + r2 <- forAll genResult + r <- liftIO $ pure r1 `runBoth` pure r2 + messages r === messages r1 ++ messages r2 + +test_runBoth2 = + prop "exception messages are also collected" $ do + r <- liftIO $ throwM (Error "boom1") `runBoth` throwM (Error "boom2") + messages r === ["boom1", "boom2"] + +-- * helpers +newtype Error = Error Text + +instance Show Error where + show (Error t) = toS t + +instance Exception Error + +genResult :: Gen Result +genResult = + choice [genEmpty, genFailed, genOk] + +genEmpty = pure Empty +genFailed = failed <$> element simpsons +genOk = ok <$> element colours + +---- +tests = $(testGroupGenerator) diff --git a/test/Test/Tasty/Extensions.hs b/test/Test/Tasty/Extensions.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tasty/Extensions.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-| + +Registry : Test.Tasty.Extensions +Description : Tasty / Hedgehog / HUnit integration + +This module unifies property based testing with Hedgehog +and one-off tests. + +-} +module Test.Tasty.Extensions ( + module Hedgehog +, module Tasty +, gotException +, prop +, test +, minTestsOk +) where + +import GHC.Stack +import Hedgehog as Hedgehog hiding (test) +import Hedgehog.Corpus as Hedgehog +import Hedgehog.Gen as Hedgehog hiding (discard, print) +import Protolude hiding ((.&.)) +import Test.Tasty as Tasty +import Test.Tasty.Hedgehog as Tasty +import Test.Tasty.TH as Tasty + +-- | Create a Tasty test from a Hedgehog property +prop :: HasCallStack => TestName -> PropertyT IO () -> [TestTree] +prop name p = [withFrozenCallStack $ testProperty name (Hedgehog.property p)] + +-- | Create a Tasty test from a Hedgehog property called only once +test :: HasCallStack => TestName -> PropertyT IO () -> [TestTree] +test name p = withFrozenCallStack $ + minTestsOk 1 . localOption (HedgehogShrinkLimit (Just (0 :: ShrinkLimit))) <$> prop name p + +gotException :: forall a . (HasCallStack, Show a) => a -> PropertyT IO () +gotException a = withFrozenCallStack $ do + res <- liftIO (try (evaluate a) :: IO (Either SomeException a)) + case res of + Left _ -> assert True + Right _ -> annotateShow ("excepted an exception" :: Text) >> assert False + + + +-- * Parameters + +minTestsOk :: Int -> (TestTree -> TestTree) +minTestsOk n = localOption (HedgehogTestLimit (Just (fromInteger (toInteger n)))) diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-}