diff --git a/cfg.cabal b/cfg.cabal --- a/cfg.cabal +++ b/cfg.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cfg -version: 0.0.2.3 +version: 0.0.2.4 synopsis: Type directed application configuration parsing and accessors @@ -59,8 +59,8 @@ UndecidableInstances build-depends: - , base >=4.16.0 && <4.20 - , containers >=0.6 && <0.7 + , base >=4.16.0 && <5 + , containers >=0.6 , free >=5.0.1 && <5.3 , mtl >=2.1 && <2.4 , pretty-simple >=4.0 && <4.2 @@ -86,6 +86,7 @@ Cfg.Deriving.Value Cfg.Env Cfg.Env.Keys + Cfg.Optional Cfg.Options Cfg.Parser Cfg.Parser.Config @@ -112,6 +113,7 @@ Cfg.Deriving.KeyModifierSpec Cfg.Env.KeysSpec Cfg.EnvSpec + Cfg.OptionalSpec Cfg.ParserSpec Cfg.SourceSpec Spec @@ -134,4 +136,4 @@ main-is: Main.hs build-depends: , cfg - , doctest >=0.21.1 && <0.23 + , doctest >=0.21.1 diff --git a/src/Cfg.hs b/src/Cfg.hs --- a/src/Cfg.hs +++ b/src/Cfg.hs @@ -341,6 +341,7 @@ import Data.Text (Text) import GHC.Generics import KeyTree +import Cfg.Optional (OptionalConfig) -- | @since 0.0.1.0 getConfigRaw @@ -479,5 +480,20 @@ via (ConfigOpts [StripPrefix "appConfig", StripSuffix "Settings", ToUpper] AppConfig5) instance DefaultSource AppConfig5 where + defaults "appConfigEnvironment" = Just "Development" + defaults _ = Nothing + +-- Example 6 +data AppConfig6 = AppConfig6 + { appConfigWarpSettings :: OptionalConfig WarpConfig + , appConfigRedisSettings :: RedisConfig + , appConfigEnvironment :: Environment + } + deriving (Generic, Show) + deriving + (ConfigSource, ConfigParser) + via (ConfigOpts [StripPrefix "appConfig", StripSuffix "Settings", ToUpper] AppConfig6) + +instance DefaultSource AppConfig6 where defaults "appConfigEnvironment" = Just "Development" defaults _ = Nothing diff --git a/src/Cfg/Optional.hs b/src/Cfg/Optional.hs new file mode 100644 --- /dev/null +++ b/src/Cfg/Optional.hs @@ -0,0 +1,25 @@ +module Cfg.Optional where + +import Cfg.Parser (ConfigParser (..), ConfigParseError (ExpectedForestFoundValue)) +import Cfg.Source (ConfigSource (..)) +import Control.Monad.Free +import Data.Map.Strict qualified as M +import KeyTree + +-- True when no leaf in the subtree carries a value. +allAbsent :: KeyTree k v -> Bool +allAbsent (Free m) = all allAbsent (M.elems m) +allAbsent (Pure _) = False + +newtype OptionalConfig a = OptionalConfig {getOptionalConfig :: Maybe a} + deriving newtype (Eq, Ord, Show) + +instance ConfigParser a => ConfigParser (OptionalConfig a) where + parseConfig cfg@(Free _) = + if allAbsent cfg + then Right $ OptionalConfig Nothing + else OptionalConfig . Just <$> parseConfig cfg + parseConfig (Pure val) = Left $ ExpectedForestFoundValue val + +instance ConfigSource a => ConfigSource (OptionalConfig a) where + configSource = configSource @a diff --git a/src/Cfg/Parser.hs b/src/Cfg/Parser.hs --- a/src/Cfg/Parser.hs +++ b/src/Cfg/Parser.hs @@ -80,6 +80,10 @@ Text -- ^ The key that was missing Text + | -- | Expected to find a subtree aka a 'Free' with a map in it, but instead + -- we found a 'Pure'. + ExpectedForestFoundValue + Text -- ^ The value that was found | -- | Expected to find a 'Pure' with a value but instead found a subtree ExpectedValueFoundForest @@ -122,7 +126,7 @@ -- | @since 0.0.1.0 instance ValueParser () where - parser = string "()" >> pure () + parser = void $ string "()" -- | @since 0.0.1.0 instance ConfigParser () @@ -203,7 +207,7 @@ -- | @since 0.0.2.0 minus :: Parser Text -minus = liftA2 (T.cons) (char '-') number +minus = liftA2 T.cons (char '-') number -- | @since 0.0.2.0 number :: Parser Text @@ -211,7 +215,7 @@ -- | @since 0.0.2.0 decimal :: Parser Text -decimal = option "" $ (T.cons) <$> char '.' <*> number +decimal = option "" $ T.cons <$> char '.' <*> number -- | @since 0.0.2.0 integral :: (Read a) => Parser a @@ -219,7 +223,7 @@ -- | @since 0.0.2.0 fractional :: (Read a) => Parser a -fractional = fmap rd $ liftA2 (<>) integral decimal +fractional = rd <$> liftA2 (<>) integral decimal -- | @since 0.0.1.0 instance ValueParser Double where diff --git a/src/Cfg/Parser/Config.hs b/src/Cfg/Parser/Config.hs --- a/src/Cfg/Parser/Config.hs +++ b/src/Cfg/Parser/Config.hs @@ -42,7 +42,7 @@ => ConfigOptions -> KeyTree Text Text -> Either ConfigParseError a -defaultParseConfig opts tree = fmap to $ gParseConfig opts tree +defaultParseConfig opts tree = to <$> gParseConfig opts tree -- | This class is the generic version of 'ConfigParser'. It recurses on the -- generic structure of a type, building up a return type for the parser. diff --git a/test/Cfg/OptionalSpec.hs b/test/Cfg/OptionalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cfg/OptionalSpec.hs @@ -0,0 +1,120 @@ +module Cfg.OptionalSpec where + +import Cfg.Deriving.Config +import Cfg.Parser +import Data.Map.Strict (empty, fromList) +import Data.Text (Text) +import GHC.Generics (Generic (..)) +import KeyTree +import Test.Hspec +import Cfg.Source (ConfigSource (..)) +import Cfg.Optional (OptionalConfig (..)) +import Cfg.Source.Default (DefaultSource) + +data SubSubTyCon = SubSubDataCon + { subSubKey1 :: Text + , subSubKey2 :: Int + } + deriving (Generic, Show, Eq, DefaultSource) + deriving (ConfigParser, ConfigSource) via (Config SubSubTyCon) + +data SubTyCon = SubDataCon + { subKey2 :: Int + , subKey1 :: OptionalConfig SubSubTyCon + } + deriving (Generic, Show, Eq, DefaultSource) + deriving (ConfigParser, ConfigSource) via (Config SubTyCon) + +data RootTyCon = RootDataCon + { key1 :: Bool + , key2 :: SubTyCon + } + deriving (Generic, Show, Eq, DefaultSource) + deriving (ConfigParser, ConfigSource) via (Config RootTyCon) + +spec :: Spec +spec = do + describe "configParser" $ do + it "should parse a type from the sample config containing a present optional config" $ do + let + subSubConfig = SubSubDataCon "Hello World" 27 + subConfig = SubDataCon 64 (OptionalConfig $ Just subSubConfig) + expected = RootDataCon True subConfig + underTest = + Free $ + fromList + [ ("key1", Pure "True") + , + ( "key2" + , Free $ + fromList + [ ("subKey1" + , Free $ fromList + [ ("subSubKey1", Pure "Hello World") + , ("subSubKey2", Pure "27") + ] + ) + , ("subKey2", Pure "64") + ] + ) + ] + parseConfig underTest `shouldBe` Right expected + it "should parse a type from the sample config with a missing optional config" $ do + let + subConfig = SubDataCon 64 (OptionalConfig Nothing) + expected = RootDataCon True subConfig + underTest = + Free $ + fromList + [ ("key1", Pure "True") + , ("key2" + , Free $ fromList + [ ("subKey2", Pure "64") + , ("subKey1", Free empty) + ] + ) + ] + parseConfig underTest `shouldBe` Right expected + it "should parse Nothing when optional config has key stubs but no values (env source style)" $ do + let + subConfig = SubDataCon 64 (OptionalConfig Nothing) + expected = RootDataCon True subConfig + underTest = + Free $ + fromList + [ ("key1", Pure "True") + , ("key2" + , Free $ fromList + [ ("subKey2", Pure "64") + , ("subKey1" + , Free $ fromList + [ ("subSubKey1", Free empty) + , ("subSubKey2", Free empty) + ] + ) + ] + ) + ] + parseConfig underTest `shouldBe` Right expected + describe "configSource" $ do + it "should create a tree from the sample config" $ do + let + expected = + Free $ + fromList + [ ("key1", Free empty) + , + ( "key2" + , Free $ + fromList + [ ("subKey1" + , Free $ fromList + [ ("subSubKey1", Free empty) + , ("subSubKey2", Free empty) + ] + ) + , ("subKey2", Free empty) + ] + ) + ] + configSource @RootTyCon `shouldBe` expected