diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +0.4.0.1 +---- + +* Improve pretty printer for configuration values (closes #32) + 0.4.0.0 ---- **BREAKING CHANGES** diff --git a/etc.cabal b/etc.cabal --- a/etc.cabal +++ b/etc.cabal @@ -1,11 +1,12 @@ -name: etc -version: 0.4.0.0 cabal-version: >=1.10 -build-type: Simple +name: etc +version: 0.4.0.1 license: MIT license-file: LICENSE copyright: 2017, 2018 Roman Gonzalez maintainer: open-source@roman-gonzalez.info +author: Roman Gonzalez +tested-with: ghc ==8.0.1 ghc ==8.0.2 ghc ==8.2.2 ghc ==8.4.2 homepage: https://github.com/roman/Haskell-etc synopsis: Declarative configuration spec for Haskell projects description: @@ -13,8 +14,7 @@ environment variables, files) using a declarative spec file that defines where these values are to be found and located in a configuration map. category: Configuration, System -author: Roman Gonzalez -tested-with: GHC ==8.0.1 GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.2 +build-type: Simple data-files: test/fixtures/config.foo test/fixtures/config.json @@ -47,15 +47,38 @@ default: False library + exposed-modules: + System.Etc + System.Etc.Spec + System.Etc.Internal.Config + System.Etc.Internal.Spec.JSON + System.Etc.Internal.Spec.Types + System.Etc.Internal.Types + System.Etc.Internal.Resolver.Default + System.Etc.Internal.Resolver.File + System.Etc.Internal.Resolver.Env + hs-source-dirs: src + other-modules: + Paths_etc + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.7 && <5, + aeson >=0.11, + hashable >=1.2, + rio >=0.0.1.0, + text >=0.0.1.0, + typed-process >=0.1.1, + unliftio >=0.1.1.0 if flag(extra) exposed-modules: System.Etc.Internal.Extra.Printer System.Etc.Internal.Extra.EnvMisspell + cpp-options: -DWITH_EXTRA build-depends: ansi-wl-pprint >=0.6, edit-distance >=0.2 - cpp-options: -DWITH_EXTRA if flag(cli) exposed-modules: @@ -63,78 +86,55 @@ System.Etc.Internal.Resolver.Cli.Common System.Etc.Internal.Resolver.Cli.Plain System.Etc.Internal.Resolver.Cli.Command + cpp-options: -DWITH_CLI build-depends: optparse-applicative >=0.12 - cpp-options: -DWITH_CLI if flag(yaml) exposed-modules: System.Etc.Internal.Spec.YAML + cpp-options: -DWITH_YAML build-depends: yaml >=0.8 - cpp-options: -DWITH_YAML - exposed-modules: - System.Etc - System.Etc.Spec - System.Etc.Internal.Config - System.Etc.Internal.Spec.JSON - System.Etc.Internal.Spec.Types - System.Etc.Internal.Types - System.Etc.Internal.Resolver.Default - System.Etc.Internal.Resolver.File - System.Etc.Internal.Resolver.Env - build-depends: - base >=4.7 && <5, - aeson >=0.11, - hashable >=1.2, - rio >=0.0.1.0, - text >=0.0.1.0, - typed-process >=0.1.1, - unliftio >=0.1.1.0 - default-language: Haskell2010 - hs-source-dirs: src + +test-suite etc-testsuite + type: exitcode-stdio-1.0 + main-is: TestSuite.hs + hs-source-dirs: test other-modules: Paths_etc + System.Etc.Resolver.DefaultTest + System.Etc.Resolver.EnvTest + System.Etc.Resolver.FileTest + System.Etc.SpecTest + System.Etc.ConfigTest + default-language: Haskell2010 ghc-options: -Wall - -test-suite etc-testsuite + build-depends: + base >=4.7, + aeson >=0.11, + rio >=0.0.1.0, + tasty >=0.11, + tasty-hunit >=0.9, + etc -any if flag(cli) - build-depends: - optparse-applicative >=0.12 cpp-options: -DWITH_CLI other-modules: System.Etc.Resolver.CliTest System.Etc.Resolver.Cli.PlainTest System.Etc.Resolver.Cli.CommandTest + build-depends: + optparse-applicative >=0.12 if flag(yaml) + cpp-options: -DWITH_YAML build-depends: yaml >=0.8 - cpp-options: -DWITH_YAML if flag(extra) - build-depends: - edit-distance >=0.2 cpp-options: -DWITH_EXTRA other-modules: System.Etc.Extra.EnvMisspellTest - type: exitcode-stdio-1.0 - main-is: TestSuite.hs - build-depends: - base >=4.7, - aeson >=0.11, - rio >=0.0.1.0, - tasty >=0.11, - tasty-hunit >=0.9, - etc -any - default-language: Haskell2010 - hs-source-dirs: test - other-modules: - Paths_etc - System.Etc.Resolver.DefaultTest - System.Etc.Resolver.EnvTest - System.Etc.Resolver.FileTest - System.Etc.SpecTest - System.Etc.ConfigTest - ghc-options: -Wall + build-depends: + edit-distance >=0.2 diff --git a/src/System/Etc/Internal/Extra/Printer.hs b/src/System/Etc/Internal/Extra/Printer.hs --- a/src/System/Etc/Internal/Extra/Printer.hs +++ b/src/System/Etc/Internal/Extra/Printer.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module System.Etc.Internal.Extra.Printer ( renderConfig , renderConfigColor @@ -9,12 +10,13 @@ , hPrintPrettyConfig ) where -import RIO hiding ((<>)) -import qualified RIO.HashMap as HashMap -import RIO.List (intersperse) -import qualified RIO.Set as Set -import qualified RIO.Text as Text -import qualified RIO.Vector as Vector +import RIO hiding ((<>)) +import qualified RIO.HashMap as HashMap +import RIO.List (intersperse) +import qualified RIO.Set as Set +import qualified RIO.Text as Text +import qualified RIO.Vector as Vector +import qualified RIO.Vector.Unsafe as Vector (unsafeHead) import qualified Data.Aeson as JSON @@ -30,16 +32,73 @@ renderConfigValueJSON :: JSON.Value -> Either Text Doc renderConfigValueJSON value = case value of - JSON.Null -> Right $ text "null" - JSON.String str -> Right $ text $ Text.unpack str - JSON.Number scientific -> Right $ text $ show scientific - JSON.Bool b -> Right $ if b then text "true" else text "false" - JSON.Object obj -> do - values <- forM (HashMap.toList obj) $ \(k, v) -> do - v1 <- renderConfigValueJSON v - return $ text (Text.unpack k) <> ":" <+> v1 + JSON.Null -> Right $ text "null" + JSON.String str -> Right $ text $ Text.unpack str + JSON.Number scientific -> Right $ text $ show scientific + JSON.Bool b -> Right $ if b then text "true" else text "false" + JSON.Array (Vector.null -> True) -> return $ text "[]" + JSON.Array arr -> do + -- unsafeHead is not unsafe here because of previous check; also we are + -- assuming all values in the array are of the same type + let h = Vector.unsafeHead arr + case h of + -- When rendering Objects within Arrays; output: + -- + -- - hello: world + -- hola: mundo + -- - foo: bar + -- baz: wat + -- + JSON.Object{} -> do + values <- forM arr $ \v -> do + v1 <- renderConfigValueJSON v + return $ hang 2 ("-" <+> v1) + + return $ align (vsep $ Vector.toList values) + + -- When rendering primitive values: + -- + -- - hello + -- - world + -- + _ -> do + values <- forM arr $ \v -> do + v1 <- renderConfigValueJSON v + return $ "-" <+> v1 + + return $ align (vsep $ Vector.toList values) + + JSON.Object obj -> do + values <- forM (HashMap.toList obj) $ \(k, v) -> case v of + -- When rendering Objects within Objects; output: + -- + -- attr1: + -- attr2: hello + -- + JSON.Object{} -> do + v1 <- renderConfigValueJSON v + return $ nest 2 (text (Text.unpack k) <> ":" <> hardline <> v1) + + -- When rendering Arrays within Objects; output: + -- + -- attr1: + -- - hello + -- + JSON.Array{} -> do + v1 <- renderConfigValueJSON v + return $ text (Text.unpack k) <> ":" <> hardline <> v1 + + -- When rendering primitive values + -- + -- hello: world + -- + -- + _ -> do + v1 <- renderConfigValueJSON v + return $ text (Text.unpack k) <> ":" <+> v1 + return $ align (vsep values) - _ -> Left $ "Trying to render Unsupported JSON value " `mappend` (tshow value) + renderConfigValue :: (JSON.Value -> Either Text Doc) -> Value JSON.Value -> Either Text [Doc] diff --git a/src/System/Etc/Internal/Spec/Types.hs b/src/System/Etc/Internal/Spec/Types.hs --- a/src/System/Etc/Internal/Spec/Types.hs +++ b/src/System/Etc/Internal/Spec/Types.hs @@ -244,7 +244,7 @@ inferErrorMsg = "could not infer type from given default value" parseBytesToConfigValueJSON :: ConfigValueType -> Text -> Maybe JSON.Value -parseBytesToConfigValueJSON cvType content = do +parseBytesToConfigValueJSON cvType content = case JSON.eitherDecodeStrict' (Text.encodeUtf8 content) of Right value | matchesConfigValueType value cvType -> return value | otherwise -> Nothing @@ -260,7 +260,7 @@ JSON.Array arr | null arr -> Left inferErrorMsg | otherwise -> case jsonToConfigValueType (Vector.head arr) of - Right (CVTArray{} ) -> Left "nested arrays values are not supported" + Right CVTArray{} -> Left "nested arrays values are not supported" Right (CVTSingle ty) -> Right $ CVTArray ty Left err -> Left err _ -> Left inferErrorMsg @@ -319,7 +319,7 @@ if HashMap.size object == 1 then do -- NOTE: not using .:? here as it casts JSON.Null to Nothing, we -- want (Just JSON.Null) returned - mDefaultValue <- pure $ maybe Nothing Just $ HashMap.lookup "default" fieldSpec + let mDefaultValue = maybe Nothing Just $ HashMap.lookup "default" fieldSpec mSensitive <- fieldSpec .:? "sensitive" mCvType <- fieldSpec .:? "type" let sensitive = fromMaybe False mSensitive diff --git a/test/System/Etc/Resolver/Cli/PlainTest.hs b/test/System/Etc/Resolver/Cli/PlainTest.hs --- a/test/System/Etc/Resolver/Cli/PlainTest.hs +++ b/test/System/Etc/Resolver/Cli/PlainTest.hs @@ -31,7 +31,7 @@ eConfig <- try $ SUT.resolvePlainCliPure spec "program" ["-g", "hello world"] case eConfig of - Left (SUT.CliEvalExited{}) -> assertBool "" True + Left SUT.CliEvalExited{} -> assertBool "" True _ -> assertFailure $ "Expecting CliEvalExited error; got this instead " <> show eConfig ] diff --git a/test/System/Etc/SpecTest.hs b/test/System/Etc/SpecTest.hs --- a/test/System/Etc/SpecTest.hs +++ b/test/System/Etc/SpecTest.hs @@ -52,7 +52,7 @@ case parseConfigSpec input of Left err -> case fromException err of - Just (InvalidConfiguration{}) -> assertBool "" True + Just InvalidConfiguration{} -> assertBool "" True _ -> assertFailure @@ -103,7 +103,7 @@ let input = "{\"etc/entries\":{\"greeting\": []}}" case parseConfigSpec input of Left err -> case fromException err of - Just (InvalidConfiguration{}) -> assertBool "" True + Just InvalidConfiguration{} -> assertBool "" True _ -> assertFailure $ "expecting InvalidConfiguration error; got instead " <> show err