diff --git a/registry.cabal b/registry.cabal --- a/registry.cabal +++ b/registry.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 27bccc93b2ea165fa0da09cc90d2c9392f38296f8240cebb4ac972dd05713611 +-- hash: 5f0e4473870f2ef16f76783ea5f7c22baddb645e5b927eac9d2b80c68b2f1a25 name: registry -version: 0.1.6.2 +version: 0.1.6.3 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. @@ -92,6 +92,15 @@ Test.Data.Registry.THSpec Test.Data.Registry.WarmupSpec Test.Tasty.Extensions + Test.Tutorial.Application + Test.Tutorial.Exercise1 + Test.Tutorial.Exercise2 + Test.Tutorial.Exercise3 + Test.Tutorial.Exercise4 + Test.Tutorial.Exercise5 + Test.Tutorial.Exercise6 + Test.Tutorial.Exercise7 + Test.Tutorial.Exercise8 Paths_registry hs-source-dirs: test @@ -101,7 +110,9 @@ MonadRandom <0.6 , async <2.3 , base >=4.7 && <5 + , bytestring <0.11 , containers >=0.5 && <0.7 + , directory <1.4 , exceptions >=0.8 && <0.11 , generic-lens <2 , hashable >=1.2 && <1.3 diff --git a/src/Data/Registry/Internal/Make.hs b/src/Data/Registry/Internal/Make.hs --- a/src/Data/Registry/Internal/Make.hs +++ b/src/Data/Registry/Internal/Make.hs @@ -15,14 +15,15 @@ -} module Data.Registry.Internal.Make where -import Data.List hiding (unlines) +import Data.List hiding (unlines) import Data.Registry.Internal.Dynamic +import Data.Registry.Internal.Reflection (showSingleType) import Data.Registry.Internal.Registry import Data.Registry.Internal.Stack import Data.Registry.Internal.Types -import Data.Text as T (unlines) -import qualified Data.Text as T -import Protolude as P hiding (Constructor) +import Data.Text as T (unlines) +import qualified Data.Text as T +import Protolude as P hiding (Constructor) import Type.Reflection -- * WARNING: HIGHLY UNTYPED IMPLEMENTATION ! @@ -52,7 +53,7 @@ Nothing -> lift $ Left $ "When trying to create the following values\n\n " <> T.intercalate "\nrequiring " (showContextTargets context) - <> "\n\nNo constructor was found for " <> show targetType + <> "\n\nNo constructor was found for " <> showSingleType targetType Just function -> do let inputTypes = collectInputTypes function @@ -83,14 +84,13 @@ modified <- storeValue modifiers v pure (Just modified) - -- | Show the target type and possibly the constructor function requiring it -- for every target type in the context showContextTargets :: Context -> [Text] showContextTargets (Context context) = fmap (\(t, f) -> case f of - Nothing -> show t + Nothing -> show t Just function -> show t <> "\t\t\t(required for the constructor " <> show function <> ")") (reverse context) diff --git a/src/Data/Registry/Internal/Reflection.hs b/src/Data/Registry/Internal/Reflection.hs --- a/src/Data/Registry/Internal/Reflection.hs +++ b/src/Data/Registry/Internal/Reflection.hs @@ -10,6 +10,7 @@ import Data.Semigroup import Data.Text as T +import Data.Typeable (tyConModule, tyConName, splitTyConApp) import Protolude as P hiding (intercalate, TypeRep, isPrefixOf, (<>)) import Type.Reflection import GHC.Exts @@ -76,11 +77,15 @@ -- | 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 + case splitTyConApp a of + (con, []) -> showType con + (con, [arg]) -> showType con <> " " <> showSingleType arg + (con, args) -> showType con <> " " <> show (fmap showSingleType args) + where showType x = + let typeWithModuleName = showWithModuleName x + in if mustShowModuleName typeWithModuleName then typeWithModuleName else show x + -- | Return true if the module name can be shown mustShowModuleName :: Text -> Bool mustShowModuleName name = not $ P.any identity $ @@ -112,6 +117,6 @@ [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 +-- | Show a type constructor with its module name +showWithModuleName :: TyCon -> Text +showWithModuleName t = toS $ tyConModule t <> "." <> tyConName t diff --git a/test/Test/Tutorial/Application.hs b/test/Test/Tutorial/Application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Application.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE RecordWildCards #-} + +module Test.Tutorial.Application where + +import qualified Data.ByteString.Char8 as BS8 +import Data.Text.Encoding (decodeUtf8) +import Protolude +import System.Directory (doesFileExist) +import System.Random + +data App = App { + userInput :: UserInput IO +, secretReader :: SecretReader IO +, rng :: Rng IO +, console :: Console IO +} + +startApp :: App -> IO () +startApp app@App{..} = do + userAnswer <- askQuestion userInput + continue <- + case userAnswer of + Maybe -> randomBool rng + No -> pure False + Yes -> pure True + + if continue then + do secret <- readSecret secretReader + case secret of + Nothing -> write console "Sorry I actually don't know" + Just s -> do + write console ("the answer is " <> s) + startApp app + else + write console "bye" + +data Logger m = Logger { + info :: Text -> m () +, error :: Text -> m () +} + +newLogger :: Logger IO +newLogger = Logger { + info = \t -> print $ "[INFO] " <> t +, error = \t -> print $ "[ERROR] " <> t +} + +data UserAnswer = Yes | No | Maybe deriving (Eq, Show) + +data UserInput m = UserInput { + askQuestion :: m UserAnswer +} + +newUserInput :: Console IO -> UserInput IO +newUserInput console = + let userInput = UserInput { + askQuestion = do + write console "Do you want to know the answer to Life, the Universe and Everything? (Yes/No/Maybe)" + answer <- read console + case answer of + "Yes" -> pure Yes + "No" -> pure No + "Maybe" -> pure Maybe + _ -> write console "Please enter Yes, No or Maybe" >> askQuestion userInput + } + in userInput + +data Rng m = Rng { + randomBool :: m Bool +} + +newRng :: Logger IO -> Rng IO +newRng logger = Rng { + randomBool = do + b <- randomIO + info logger ("generated a random boolean " <> show b) + pure b +} + +-- Get the secret answer and return Nothing if not found +data SecretReader m = SecretReader { + readSecret :: m (Maybe Text) +} + +data SecretReaderConfig = SecretReaderConfig Text deriving (Eq, Show) + +newSecretReader :: SecretReaderConfig -> Logger IO -> SecretReader IO +newSecretReader (SecretReaderConfig path) logger = SecretReader { + readSecret = do + exists <- doesFileExist (toS path) + if exists then Just . decodeUtf8 <$> BS8.readFile (toS path) + else error logger ("file does not exist at " <> path) $> Nothing +} + +data Console m = Console { + write :: Text -> m () +, read :: m Text +} + +newConsole :: Console IO +newConsole = Console putStrLn (toS <$> getLine) diff --git a/test/Test/Tutorial/Exercise1.hs b/test/Test/Tutorial/Exercise1.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise1.hs @@ -0,0 +1,17 @@ +module Test.Tutorial.Exercise1 where + +import Test.Tutorial.Application + +newApp :: App +newApp = + let logger' = newLogger + console' = newConsole + userInput' = newUserInput console' + rng' = newRng logger' + secretReader' = newSecretReader (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") logger' + in App { + userInput = userInput' + , console = console' + , rng = rng' + , secretReader = secretReader' + } diff --git a/test/Test/Tutorial/Exercise2.hs b/test/Test/Tutorial/Exercise2.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise2.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Test.Tutorial.Exercise2 where + +import Test.Tutorial.Application +import Data.Registry + +registry :: Registry _ _ +registry = + fun App + +: fun newLogger + +: fun newConsole + +: fun newUserInput + +: fun newRng + +: fun newSecretReader + +: val (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") + +: end + +newApp :: App +newApp = make @App registry diff --git a/test/Test/Tutorial/Exercise3.hs b/test/Test/Tutorial/Exercise3.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise3.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Test.Tutorial.Exercise3 where + +import Data.Registry +import Protolude +import Test.Tutorial.Application +import Test.Tutorial.Exercise2 + +silentLogger :: Logger IO +silentLogger = Logger (const (pure ())) (const (pure ())) + +silentRegistry = fun silentLogger +: registry + +newSilentApp :: App +newSilentApp = make @App silentRegistry + +newMisconfiguredApp :: App +newMisconfiguredApp = make @App (val (SecretReaderConfig "missing") +: registry) + +newMisconfiguredSilentApp :: App +newMisconfiguredSilentApp = make @App (val (SecretReaderConfig "missing") +: silentRegistry) + +newMisconfiguredRngSilentApp :: App +newMisconfiguredRngSilentApp = make @App $ + specialize @(Rng IO) silentLogger $ + val (SecretReaderConfig "missing") +: registry diff --git a/test/Test/Tutorial/Exercise4.hs b/test/Test/Tutorial/Exercise4.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise4.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Test.Tutorial.Exercise4 where + +import Data.Registry +import Protolude +import Test.Tutorial.Application +import Test.Tutorial.Exercise2 +import Test.Tutorial.Exercise3 + +printApp :: IO () +printApp = putStrLn $ unDot $ makeDot @App $ + specialize @(Rng IO) silentLogger $ + val (SecretReaderConfig "missing") +: registry diff --git a/test/Test/Tutorial/Exercise5.hs b/test/Test/Tutorial/Exercise5.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise5.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Test.Tutorial.Exercise5 where + +import qualified Data.ByteString.Char8 as BS8 +import Data.Registry +import Data.Text.Encoding (decodeUtf8) +import Protolude +import System.Directory (doesFileExist) +import Test.Tutorial.Application + +newCheckedSecretReader :: SecretReaderConfig -> Logger IO -> IO (SecretReader IO) +newCheckedSecretReader (SecretReaderConfig path) logger = do + exists <- doesFileExist (toS path) + if not exists then fileDoesNotExist else pure () + pure SecretReader { + readSecret = do + if exists then Just . decodeUtf8 <$> BS8.readFile (toS path) + else fileDoesNotExist $> Nothing + } + + where + fileDoesNotExist = error logger ("file does not exist at " <> path) + + +registryIO :: Registry _ _ +registryIO = + funTo @IO App + +: funTo @IO newLogger + +: funTo @IO newConsole + +: funTo @IO newUserInput + +: funTo @IO newRng + +: funAs @IO newCheckedSecretReader + +: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") + +: end + +newAppIO :: IO App +newAppIO = make @(IO App) registryIO diff --git a/test/Test/Tutorial/Exercise6.hs b/test/Test/Tutorial/Exercise6.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise6.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Test.Tutorial.Exercise6 where + +import Data.Registry +import Protolude +import System.Directory (doesFileExist) +import Test.Tutorial.Application + +newCheckedSecretReader :: SecretReaderConfig -> Logger IO -> Tag "unchecked" (SecretReader IO) -> IO (SecretReader IO) +newCheckedSecretReader (SecretReaderConfig path) logger uncheckedReader = do + exists <- doesFileExist (toS path) + if not exists then fileDoesNotExist else pure () + pure $ unTag uncheckedReader + where + fileDoesNotExist = error logger ("file does not exist at " <> path) + +registryIO :: Registry _ _ +registryIO = + funTo @IO App + +: funTo @IO newLogger + +: funTo @IO newConsole + +: funTo @IO newUserInput + +: funTo @IO newRng + +: funAs @IO newCheckedSecretReader + +: funTo @IO (tag @"unchecked" newSecretReader) + +: valTo @IO (SecretReaderConfig "txe/tests/Test/Tutorial/secret.txt") + +: end + +newAppIO :: IO App +newAppIO = make @(IO App) registryIO diff --git a/test/Test/Tutorial/Exercise7.hs b/test/Test/Tutorial/Exercise7.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise7.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Test.Tutorial.Exercise7 where + +import Data.Registry +import Protolude +import Test.Tutorial.Application +import Test.Tutorial.Exercise6 + +newInitializedLogger :: IO (Logger IO) +newInitializedLogger = do + print ("start the logger" :: Text) + pure (Logger putStrLn putStrLn) + +newInitializedRegistry :: Registry _ _ +newInitializedRegistry = fun newInitializedLogger +: registryIO + +newInitializedAppIO :: IO App +newInitializedAppIO = make @(IO App) newInitializedRegistry + +memoizedRegistry :: IO (Registry _ _) +memoizedRegistry = memoize @IO @(Logger IO) newInitializedRegistry + +newInitializedMemoizedAppIO :: IO App +newInitializedMemoizedAppIO = make @(IO App) =<< memoizedRegistry + +memoizedAllRegistry :: IO (Registry _ _) +memoizedAllRegistry = memoizeAll @IO newInitializedRegistry + +newInitializedMemoizedAllAppIO :: IO App +newInitializedMemoizedAllAppIO = make @(IO App) =<< memoizedAllRegistry diff --git a/test/Test/Tutorial/Exercise8.hs b/test/Test/Tutorial/Exercise8.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise8.hs @@ -0,0 +1,28 @@ +{-# 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