etc 0.0.0.1 → 0.0.0.2
raw patch · 7 files changed
+336/−159 lines, 7 filesdep +edit-distancePVP ok
version bump matches the API change (PVP)
Dependencies added: edit-distance
API changes (from Hackage documentation)
Files
- etc.cabal +15/−7
- src/System/Etc.hs +23/−8
- src/System/Etc/Internal/Extra/EnvMisspell.hs +105/−0
- src/System/Etc/Internal/Extra/Printer.hs +144/−0
- src/System/Etc/Internal/Printer.hs +0/−144
- test/System/Etc/Extra/EnvMisspellTest.hs +41/−0
- test/TestSuite.hs +8/−0
etc.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: etc-version: 0.0.0.1+version: 0.0.0.2 synopsis: Declarative configuration spec for Haskell projects description: Please see README.md category: Configuration, System@@ -30,8 +30,8 @@ type: git location: https://github.com/roman/Haskell-etc -flag printer- description: Include support for config printer+flag extra+ description: Include extra utilities manual: False default: False @@ -78,12 +78,15 @@ default-language: Haskell2010 - if flag(printer)- cpp-options: -DWITH_PRINTER+ if flag(extra)+ cpp-options: -DWITH_EXTRA build-depends:- ansi-wl-pprint >=0.6 && <0.7+ ansi-wl-pprint >=0.6 && <0.7,+ edit-distance >=0.2 && <0.3+ exposed-modules:- System.Etc.Internal.Printer+ System.Etc.Internal.Extra.Printer+ System.Etc.Internal.Extra.EnvMisspell if flag(cli) cpp-options: -DWITH_CLI@@ -130,6 +133,10 @@ cpp-options: -DWITH_YAML build-depends: yaml >=0.8 && <0.9+ if flag(extra)+ cpp-options: -DWITH_EXTRA+ build-depends:+ edit-distance >=0.2 && <0.3 other-modules: Paths_etc System.Etc.Resolver.CliTest@@ -138,5 +145,6 @@ System.Etc.Resolver.DefaultTest System.Etc.Resolver.EnvTest System.Etc.Resolver.FileTest+ System.Etc.Extra.EnvMisspellTest System.Etc.SpecTest default-language: Haskell2010
src/System/Etc.hs view
@@ -43,12 +43,19 @@ , CliConfigError(..) #endif -#ifdef WITH_PRINTER- -- * Printer- -- $printer+#ifdef WITH_EXTRA+ -- * Extra utilities+ -- $extra , renderConfig , printPrettyConfig , hPrintPrettyConfig++ , EnvMisspell(..)+ , getEnvMisspellings+ , getEnvMisspellingsPure+ , renderEnvMisspellings+ , hPrintEnvMisspellings+ , reportEnvMisspellingWarnings #endif ) where @@ -63,8 +70,17 @@ import System.Etc.Internal.Resolver.Cli.Plain (resolvePlainCli, resolvePlainCliPure) #endif -#ifdef WITH_PRINTER-import System.Etc.Internal.Printer (hPrintPrettyConfig, printPrettyConfig, renderConfig)+#ifdef WITH_EXTRA+import System.Etc.Internal.Extra.EnvMisspell+ ( EnvMisspell (..)+ , getEnvMisspellings+ , getEnvMisspellingsPure+ , hPrintEnvMisspellings+ , renderEnvMisspellings+ , reportEnvMisspellingWarnings+ )+import System.Etc.Internal.Extra.Printer+ (hPrintPrettyConfig, printPrettyConfig, renderConfig) #endif import System.Etc.Internal.Config@@ -93,8 +109,7 @@ together using the mappend function -} -{- $printer+{- $extra - Use these function to render the configuration map and understand how the- resolving was performed.+ Some extra utilities that are great for debugging (miss)-configurations. -}
+ src/System/Etc/Internal/Extra/EnvMisspell.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module System.Etc.Internal.Extra.EnvMisspell (+ EnvMisspell (..)+ , getEnvMisspellings+ , getEnvMisspellingsPure+ , renderEnvMisspellings+ , hPrintEnvMisspellings+ , reportEnvMisspellingWarnings+ ) where++import Protolude hiding ((<$>), (<>))++import Data.Vector (Vector)+import System.Environment (getEnvironment)++import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import qualified Text.EditDistance as Distance++import System.Etc.Internal.Spec.Types+import Text.PrettyPrint.ANSI.Leijen++data EnvMisspell+ = EnvMisspell {+ currentText :: Text+ , suggestionText :: Text+ }+ deriving (Show, Eq, Generic)++lookupSpecEnvKeys :: ConfigSpec a -> Vector Text+lookupSpecEnvKeys spec =+ let+ foldEnvSettings val acc =+ case val of+ ConfigValue _ sources ->+ maybe acc (`Vector.cons` acc) (envVar sources)+ SubConfig hsh ->+ HashMap.foldr foldEnvSettings acc hsh+ in+ foldEnvSettings (SubConfig $ specConfigValues spec) Vector.empty++{-|++-}+getEnvMisspellingsPure :: ConfigSpec a -> Vector Text -> Vector EnvMisspell+getEnvMisspellingsPure spec env = do+ specEnvName <- lookupSpecEnvKeys spec+ currentEnvName <- env++ let+ distance =+ Distance.levenshteinDistance+ Distance.defaultEditCosts+ (Text.unpack specEnvName)+ (Text.unpack currentEnvName)++ guard (distance >= 1 && distance < 4)+ return $ EnvMisspell currentEnvName specEnvName++{-|++-}+getEnvMisspellings :: ConfigSpec a -> IO (Vector EnvMisspell)+getEnvMisspellings spec =+ getEnvironment+ & fmap (Vector.fromList . map (Text.pack . fst))+ & fmap (getEnvMisspellingsPure spec)++{-|++-}+renderEnvMisspellings :: Vector EnvMisspell -> Doc+renderEnvMisspellings misspells+ | Vector.null misspells =+ mempty+ | otherwise =+ misspells+ & Vector.map+ (\misspell ->+ text "WARNING: Environment variable `"+ <> text (Text.unpack $ currentText misspell)+ <> text "' found, perhaps you meant `"+ <> text (Text.unpack $ suggestionText misspell)+ <> text "'")+ & Vector.foldl' (<$>) mempty+ & (<$> mempty)+ & (<$> mempty)++{-|++-}+hPrintEnvMisspellings :: Handle -> Vector EnvMisspell -> IO ()+hPrintEnvMisspellings h =+ hPutDoc h . renderEnvMisspellings++{-|++-}+reportEnvMisspellingWarnings :: ConfigSpec a -> IO ()+reportEnvMisspellingWarnings spec =+ getEnvMisspellings spec >>=+ hPrintEnvMisspellings stderr
+ src/System/Etc/Internal/Extra/Printer.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module System.Etc.Internal.Extra.Printer (+ renderConfig+ , printPrettyConfig+ , hPrintPrettyConfig+ ) where++import Protolude hiding ((<>))++import qualified Data.Aeson as JSON+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Set as Set+import qualified Data.Text as Text++import Text.PrettyPrint.ANSI.Leijen++import System.Etc.Internal.Types++renderJsonValue :: JSON.Value -> (Doc, Int)+renderJsonValue value' =+ case value' of+ JSON.String str ->+ (text $ Text.unpack str, Text.length str)++ JSON.Number scientific ->+ let+ number =+ show scientific+ in+ (text number, length number)+ JSON.Bool bool' ->+ if bool' then+ (text "true", 5)+ else+ (text "false", 5)+ _ ->+ value'+ & show+ & ("Invalid configuration value creation " `mappend`)+ & InvalidConfiguration+ & show+ & error+++renderConfig :: Config -> Doc+renderConfig (Config configValue0) =+ let+ brackets' = enclose (lbracket <> space) (space <> rbracket)++ renderSource :: ConfigSource -> ((Doc, Int), Doc)+ renderSource source' =+ case source' of+ Default value' ->+ ( renderJsonValue value'+ , brackets' (fill 10 (text "Default"))+ )++ File _index filepath' value' ->+ ( renderJsonValue value'+ , brackets' (fill 10 (text "File:" <+> text (Text.unpack filepath')))+ )++ Env varname value' ->+ ( renderJsonValue value'+ , brackets' (fill 10 (text "Env:" <+> text (Text.unpack varname)))+ )++ Cli value' ->+ ( renderJsonValue value'+ , brackets' (fill 10 (text "Cli"))+ )++ None ->+ ( (mempty, 0)+ , mempty+ )++ renderSources :: [ConfigSource] -> Doc+ renderSources sources0 =+ let+ sources@(((selValueDoc, _), selSourceDoc):others) =+ map renderSource sources0++ fillingWidth =+ sources+ & map (snd . fst)+ & maximum+ & max 10++ selectedValue =+ [ green $ fill fillingWidth selValueDoc <+> selSourceDoc ]++ otherValues =+ map (\((valueDoc, _), sourceDoc) ->+ fill fillingWidth valueDoc <+> sourceDoc)+ others+ in+ selectedValue+ & flip mappend otherValues+ & vcat+ & indent 2++ configEntryRenderer :: [Text] -> [Doc] -> Text -> ConfigValue -> [Doc]+ configEntryRenderer keys resultDoc configKey configValue =+ resultDoc `mappend` loop (configKey : keys) configValue++ loop keys configValue =+ case configValue of+ SubConfig subConfigm ->+ HashMap.foldlWithKey'+ (configEntryRenderer keys)+ mempty+ subConfigm++ ConfigValue sources0 ->+ let+ configKey =+ keys+ & reverse+ & Text.intercalate "."++ sources =+ Set.toDescList sources0+ in+ if null sources then+ []+ else+ [ blue (text (Text.unpack configKey))+ <$$> renderSources sources ]+ in+ loop [] configValue0+ & intersperse (linebreak <> linebreak)+ & hcat+ & (<> linebreak)++printPrettyConfig :: Config -> IO ()+printPrettyConfig =+ putDoc . renderConfig++hPrintPrettyConfig :: Handle -> Config -> IO ()+hPrintPrettyConfig handle' =+ hPutDoc handle' . renderConfig
− src/System/Etc/Internal/Printer.hs
@@ -1,144 +0,0 @@-{-# OPTIONS_GHC -fno-warn-deprecations #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-module System.Etc.Internal.Printer (- renderConfig- , printPrettyConfig- , hPrintPrettyConfig- ) where--import Protolude hiding ((<>))--import qualified Data.Aeson as JSON-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Set as Set-import qualified Data.Text as Text--import Text.PrettyPrint.ANSI.Leijen--import System.Etc.Internal.Types--renderJsonValue :: JSON.Value -> (Doc, Int)-renderJsonValue value' =- case value' of- JSON.String str ->- (text $ Text.unpack str, Text.length str)-- JSON.Number scientific ->- let- number =- show scientific- in- (text number, length number)- JSON.Bool bool' ->- if bool' then- (text "true", 5)- else- (text "false", 5)- _ ->- value'- & show- & ("Invalid configuration value creation " `mappend`)- & InvalidConfiguration- & show- & error---renderConfig :: Config -> Doc-renderConfig (Config configValue0) =- let- brackets' = enclose (lbracket <> space) (space <> rbracket)-- renderSource :: ConfigSource -> ((Doc, Int), Doc)- renderSource source' =- case source' of- Default value' ->- ( renderJsonValue value'- , brackets' (fill 10 (text "Default"))- )-- File _index filepath' value' ->- ( renderJsonValue value'- , brackets' (fill 10 (text "File:" <+> text (Text.unpack filepath')))- )-- Env varname value' ->- ( renderJsonValue value'- , brackets' (fill 10 (text "Env:" <+> text (Text.unpack varname)))- )-- Cli value' ->- ( renderJsonValue value'- , brackets' (fill 10 (text "Cli"))- )-- None ->- ( (mempty, 0)- , mempty- )-- renderSources :: [ConfigSource] -> Doc- renderSources sources0 =- let- sources@(((selValueDoc, _), selSourceDoc):others) =- map renderSource sources0-- fillingWidth =- sources- & map (snd . fst)- & maximum- & max 10-- selectedValue =- [ green $ fill fillingWidth selValueDoc <+> selSourceDoc ]-- otherValues =- map (\((valueDoc, _), sourceDoc) ->- fill fillingWidth valueDoc <+> sourceDoc)- others- in- selectedValue- & flip mappend otherValues- & vcat- & indent 2-- configEntryRenderer :: [Text] -> [Doc] -> Text -> ConfigValue -> [Doc]- configEntryRenderer keys resultDoc configKey configValue =- resultDoc `mappend` loop (configKey : keys) configValue-- loop keys configValue =- case configValue of- SubConfig subConfigm ->- HashMap.foldlWithKey'- (configEntryRenderer keys)- mempty- subConfigm-- ConfigValue sources0 ->- let- configKey =- keys- & reverse- & Text.intercalate "."-- sources =- Set.toDescList sources0- in- if null sources then- []- else- [ blue (text (Text.unpack configKey))- <$$> renderSources sources ]- in- loop [] configValue0- & intersperse (linebreak <> linebreak)- & hcat- & (<> linebreak)--printPrettyConfig :: Config -> IO ()-printPrettyConfig =- putDoc . renderConfig--hPrintPrettyConfig :: Handle -> Config -> IO ()-hPrintPrettyConfig handle' =- hPutDoc handle' . renderConfig
+ test/System/Etc/Extra/EnvMisspellTest.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module System.Etc.Extra.EnvMisspellTest where++import Protolude++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import qualified Data.Vector as Vector++import System.Etc++tests :: TestTree+tests =+ testGroup "env misspells"+ [+ testCase "it warns when misspell is present" $ do+ let+ input =+ mconcat+ [+ "{\"etc/entries\": {"+ , " \"greeting\": { \"etc/spec\": { \"env\": \"GREETING\" }}}}"+ ]++ (spec :: ConfigSpec ()) <- parseConfigSpec input++ let+ result =+ getEnvMisspellingsPure spec ["GREEING"]++ assertBool "expecting to get a warning for typo"+ (not $ Vector.null result)++ assertEqual "expecting to get typo for key GREETING"+ (EnvMisspell "GREEING" "GREETING")+ (Vector.head result)+ ]
test/TestSuite.hs view
@@ -18,6 +18,10 @@ import qualified System.Etc.Resolver.CliTest #endif +#ifdef WITH_EXTRA+import qualified System.Etc.Extra.EnvMisspellTest+#endif+ main :: IO () main = defaultMainWithIngredients@@ -28,5 +32,9 @@ , System.Etc.Resolver.EnvTest.tests #ifdef WITH_CLI , System.Etc.Resolver.CliTest.tests+#endif++#ifdef WITH_EXTRA+ , System.Etc.Extra.EnvMisspellTest.tests #endif ])