packages feed

registry 0.1.6.2 → 0.1.6.3

raw patch · 12 files changed

+351/−16 lines, 12 filesdep +bytestringdep +directory

Dependencies added: bytestring, directory

Files

registry.cabal view
@@ -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
src/Data/Registry/Internal/Make.hs view
@@ -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)
src/Data/Registry/Internal/Reflection.hs view
@@ -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
+ test/Test/Tutorial/Application.hs view
@@ -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)
+ test/Test/Tutorial/Exercise1.hs view
@@ -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'+  }
+ test/Test/Tutorial/Exercise2.hs view
@@ -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
+ test/Test/Tutorial/Exercise3.hs view
@@ -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
+ test/Test/Tutorial/Exercise4.hs view
@@ -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
+ test/Test/Tutorial/Exercise5.hs view
@@ -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
+ test/Test/Tutorial/Exercise6.hs view
@@ -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
+ test/Test/Tutorial/Exercise7.hs view
@@ -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
+ test/Test/Tutorial/Exercise8.hs view
@@ -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