cfg 0.0.1.0 → 0.0.2.0

raw patch · 33 files changed

+2549/−1245 lines, 33 filesdep +doctestdep +freedep ~pretty-simplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: doctest, free

Dependency ranges changed: pretty-simple

API changes (from Hackage documentation)

Files

• cfg.cabal +27/−24
• doctest/Main.hs +45/−0
• src/Cfg.hs +409/−483
• src/Cfg/Deriving.hs +17/−8
• src/Cfg/Deriving/Assert.hs +42/−16
• src/Cfg/Deriving/Config.hs +348/−0
• src/Cfg/Deriving/ConfigRoot.hs +0/−52
• src/Cfg/Deriving/ConfigValue.hs +0/−19
• src/Cfg/Deriving/KeyModifier.hs +198/−0
• src/Cfg/Deriving/LabelModifier.hs +0/−22
• src/Cfg/Deriving/SubConfig.hs +0/−46
• src/Cfg/Deriving/Value.hs +40/−0
• src/Cfg/Env.hs +127/−28
• src/Cfg/Env/Keys.hs +104/−18
• src/Cfg/Options.hs +77/−7
• src/Cfg/Parser.hs +149/−56
• src/Cfg/Parser/Config.hs +135/−0
• src/Cfg/Parser/ConfigParser.hs +0/−94
• src/Cfg/Parser/Value.hs +74/−0
• src/Cfg/Parser/ValueParser.hs +0/−41
• src/Cfg/Source.hs +71/−45
• src/Cfg/Source/Config.hs +161/−0
• src/Cfg/Source/Default.hs +28/−0
• src/Cfg/Source/NestedConfig.hs +0/−58
• src/Cfg/Source/RootConfig.hs +0/−37
• src/KeyTree.hs +161/−0
• src/Tree/Append.hs +0/−41
• test/Cfg/Deriving/KeyModifierSpec.hs +54/−0
• test/Cfg/Env/KeysSpec.hs +99/−0
• test/Cfg/EnvSpec.hs +57/−76
• test/Cfg/ParserSpec.hs +28/−23
• test/Cfg/SourceSpec.hs +87/−42
• test/Main.hs +11/−9

@@ -1,7 +1,9 @@ cabal-version: 3.0 name:          cfg-version:       0.0.1.0-synopsis:      Type generated application configuration +version:       0.0.2.0+synopsis:+  Type directed application configuration parsing and accessors+ description:   `cfg` is a library that provides Generic machinery for generating configuration accessors,    and parsers from Haskell types. This package is intended to be used to build out additional @@ -46,6 +48,7 @@     NamedFieldPuns     NumericUnderscores     OverloadedStrings+    PolyKinds     RecordWildCards     ScopedTypeVariables     StandaloneDeriving@@ -53,12 +56,14 @@     TypeApplications     TypeFamilies     TypeOperators+    UndecidableInstances    build-depends:     , base           >=4.18.0 && <4.19     , containers     >=0.6.7  && <0.7+    , free           >=5.1.10 && <5.2     , mtl            >=2.3.1  && <2.4-    , pretty-simple+    , pretty-simple  >=4.1.2  && <4.2     , text           >=2.0.2  && <2.1    default-language:   Haskell2010@@ -76,20 +81,19 @@     Cfg     Cfg.Deriving     Cfg.Deriving.Assert-    Cfg.Deriving.ConfigRoot-    Cfg.Deriving.ConfigValue-    Cfg.Deriving.LabelModifier-    Cfg.Deriving.SubConfig+    Cfg.Deriving.Config+    Cfg.Deriving.KeyModifier+    Cfg.Deriving.Value     Cfg.Env     Cfg.Env.Keys     Cfg.Options     Cfg.Parser-    Cfg.Parser.ConfigParser-    Cfg.Parser.ValueParser+    Cfg.Parser.Config+    Cfg.Parser.Value     Cfg.Source-    Cfg.Source.NestedConfig-    Cfg.Source.RootConfig-    Tree.Append+    Cfg.Source.Config+    Cfg.Source.Default+    KeyTree    hs-source-dirs:  src   ghc-options:     -Wall -fdefer-typed-holes@@ -105,6 +109,8 @@    -- cabal-fmt: expand test -Main   other-modules:+    Cfg.Deriving.KeyModifierSpec+    Cfg.Env.KeysSpec     Cfg.EnvSpec     Cfg.ParserSpec     Cfg.SourceSpec@@ -119,15 +125,12 @@     , hspec-expectations  >=0.8.2 && <0.9     , hspec-hedgehog      >=0.0.1 && <0.1 --- test-suite doctests---   import:           common-opts---   type:             exitcode-stdio-1.0---   hs-source-dirs:   test---   main-is:          doctests.hs---   ghc-options:      -threaded---   build-depends:---     , cfg---     , doctest-parallel---     , pretty-simple------   default-language: Haskell2010+test-suite documentation+  import:         common-opts+  type:           exitcode-stdio-1.0+  hs-source-dirs: doctest+  ghc-options:    -Wall -threaded -rtsopts -with-rtsopts=-N+  main-is:        Main.hs+  build-depends:+    , cfg+    , doctest  >=0.21.1 && <0.22

@@ -0,0 +1,45 @@+module Main where++import Test.DocTest++main :: IO ()+main = doctest+  [ "-isrc/"+  , "--fast"+  ,  "-XAllowAmbiguousTypes"+  ,  "-XBlockArguments"+  ,  "-XConstraintKinds"+  ,  "-XDataKinds"+  ,  "-XDeriveAnyClass"+  ,  "-XDeriveFunctor"+  ,  "-XDeriveGeneric"+  ,  "-XDerivingStrategies"+  ,  "-XDerivingVia"+  ,  "-XEmptyCase"+  ,  "-XFlexibleContexts"+  ,  "-XFlexibleInstances"+  ,  "-XGADTs"+  ,  "-XGeneralizedNewtypeDeriving"+  ,  "-XImportQualifiedPost"+  ,  "-XInstanceSigs"+  ,  "-XKindSignatures"+  ,  "-XLambdaCase"+  ,  "-XMultiParamTypeClasses"+  ,  "-XMultiWayIf"+  ,  "-XNamedFieldPuns"+  ,  "-XNumericUnderscores"+  ,  "-XOverloadedStrings"+  ,  "-XRecordWildCards"+  ,  "-XScopedTypeVariables"+  ,  "-XStandaloneDeriving"+  ,  "-XTupleSections"+  ,  "-XTypeApplications"+  ,  "-XTypeFamilies"+  ,  "-XTypeOperators"+  ,  "-XUndecidableInstances"+  ,  "-XPolyKinds"+  , "src/Cfg.hs"+  , "src/Cfg/Env/Keys.hs"+  , "src/KeyTree.hs"+  , "src/Cfg/Env.hs"+  ]

@@ -1,3 +1,5 @@+{-# LANGUAGE DuplicateRecordFields #-}+ -- | --  Module      : Cfg --  Copyright   : © Jonathan Lorimer, 2023@@ -5,540 +7,464 @@ --  Maintainer  : jonathanlorimer@pm.me --  Stability   : stable ----- @since 0.0.1.0 +-- @since 0.0.1.0 -- -- This package provides an api for representing configuration as a haskell -- type. This entails three general considerations: a simplified--- representation our haskell type so that it maps better to existing--- configuration tools, an adapter to translate between the simplified+-- representation of our haskell type so that it maps better to existing+-- configuration formats, an adapter to translate between the simplified -- representation and a concrete configuration "source" (i.e. environment--- variables, yaml files, etc.), and a parser that can translate between the--- abstract representation and the concrete haskell type.+-- variables, yaml files, etc.), and a parser that can recover the structure of+-- the haskell type from the simplified representation. -- -- While this package provides a default source (environment variables), the -- intention is that other packages will provide additional sources.+module Cfg+  ( -- * Concepts -module Cfg (--- * Concepts------ |------ The core concepts in this package are:------    * __A simplified type representation:__ The type chosen to represent our---    underlying haskell type is 'Data.Tree.Tree'. This reflects the---    potentially nested structure of configuration, and makes it easy to nest---    keys and then simply append values as leaf nodes. ------    * __Sources:__ These represent a way to build a simplified representation---    from as Haskell type. Source may seem like an odd name, but other names---    like \"Rep\", or \"Representation\" are taken and overloaded. The tree---    structures created by the typeclasses in "Cfg.Source" are what is used to---    request values from a configuration source.------    * __Parsers:__ Once a request for configuration values has been made to a---    source, and the actual values are appended as leaf nodes on the tree---    representation we require a parser to pull that information out and---    construct a Haskell type. The parser traverses the tree and makes sure---    that it structurally matches our Haskell type, and then it will parse the---    'Data.Text.Text' values at the leaves into actual actual Haskell types.---    The api that corresponds to this part can be found in "Cfg.Parser".------    * __Deriving:__ It is a design principle of this library that the vast---    majority (if not all) functionality should be derivable. For this we use---    "GHC.Generics", and deriving via. You can always hand write instances for---    custom functionality, but there are also a handful of options that can be---    specified using the deriving machinery. Documentation on those options---    can be found in "Cfg.Deriving".------    * __Roots and nesting__: In general there is a distinction between the---    "Root" type for a configuration, and then subtypes that are arbitrarily---    nested under the root type (or other nested configurations). This makes---    some parts of the Generic machinery easier, but also serves some---    practical purposes (i.e. subconfig keys are picked from record field---    names, while the root key is picked from the root type's type name).+    -- |+    --+    -- The core concepts in this package are:+    --+    --    * __A simplified type representation:__ The type chosen to represent our+    --    underlying haskell type is 'KeyTree.KeyTree'. This reflects the+    --    potentially nested structure of configuration, and makes it easy+    --    simply append values as leaf nodes.+    --+    --    * __Sources:__ These represent a way to build a simplified representation+    --    from as Haskell type. Source may seem like an odd name, but other+    --    names like \"Rep\", or \"Representation\" are taken and overloaded.+    --    The tree structures created by the typeclasses in "Cfg.Source" are+    --    used to request values from a configuration source.+    --+    --    * __Parsers:__ Once a request for configuration values has been made to a+    --    source, and the actual values are appended as leaf nodes on the tree+    --    representation we require a parser to pull that information out and+    --    construct a Haskell type. The parser traverses the tree and makes sure+    --    that it structurally matches our Haskell type, and then it will parse the+    --    'Data.Text.Text' values at the leaves into actual Haskell types.+    --    The api that corresponds to this can be found in "Cfg.Parser".+    --+    --    * __Deriving:__ It is a design principle of this library that the+    --    vast majority (if not all) functionality should be derivable. For+    --    this we use "GHC.Generics", and [deriving+    --    via](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/deriving_via.html).+    --    You can always hand write instances for custom functionality, but+    --    there are also a handful of options that can be specified using the+    --    deriving machinery. Documentation on those options can be found in+    --    "Cfg.Deriving". --- * Quickstart guide------ |------ Here we will introduce some sample code that should get you up and running--- quickly. We will also explain some of the internals so you can see how--- things are wired together+    -- * Quickstart guide --- ** Sample configuration------ |------ Let's start out with a couple types that represent some imaginary--- configuration for an imaginary application. You will probably notice that we--- derive the 'RootConfig' class for our top level config @AppConfig@ and we do--- this via the 'ConfigRoot' type. We derive the 'NestedConfig' class for all--- the nested product types via the 'SubConfig' type. Finally, for--- @Environment@, which is not really a configuration, but rather a value that--- can be configured, we derive 'NestedConfig' via 'ConfigValue'.------ This is all probably a bit opaque, to understand the 'RootConfig' and--- 'NestedConfig' class better you can read the "Cfg.Source" module. To--- understand the deriving mechanisms better you can read the "Cfg.Deriving"--- module.------ @--- {-# LANGUAGE DeriveGeneric #-}--- {-# LANGUAGE DerivingVia #-}------ import "Cfg.Deriving" (ConfigValue, ConfigRoot, SubConfig)--- import "Cfg.Source" (RootConfig, NestedConfig)--- import Data.ByteString (ByteString)--- import Data.Text (Text)--- import GHC.Generics------ data Environment = Development | Production---   deriving stock (Generic, Show)---   deriving ('NestedConfig') via ('ConfigValue' Environment)------ data WarpConfig = WarpConfig---   { warpConfigPort :: Int---   , warpConfigTimeout :: Int---   , warpConfigHTTP2Enabled :: Bool---   , warpConfigServerName :: ByteString---   }---   deriving (Generic, Show)---   deriving ('NestedConfig') via ('SubConfig' WarpConfig)------ data RedisConfig = RedisConfig---   { redisConfigHost :: Text---   , redisConfigPort :: Int---   , redisConfigConnectAuth :: Maybe ByteString---   }---   deriving (Generic, Show)---   deriving ('NestedConfig') via ('SubConfig' RedisConfig)------ data AppConfig = AppConfig---   { appConfigWarpSettings :: WarpConfig---   , appConfigRedisSettings :: RedisConfig---   , appConfigEnvironment :: Environment---   }---   deriving stock (Generic, Show)---   deriving ('RootConfig') via ('ConfigRoot' AppConfig)--- @+    -- |+    --+    -- Here we will introduce some sample code that should get you up and running+    -- quickly. We will also explain some of the internals so you can see how+    -- things are wired together --- ** Generated representation------ |------ Below we can see a doctest example that shows the internal \"simplified--- representation\" that this library uses.------ >>> import Text.Pretty.Simple (pPrint) --- >>> import Cfg.Source () -- Pulls in the RootConfig instance for 'toRootConfig'--- >>> pPrint $ toRootConfig @AppConfig--- Node---     { rootLabel = "AppConfig"---     , subForest =---         [ Node---             { rootLabel = "appConfigWarpSettings"---             , subForest =---                 [ Node---                     { rootLabel = "warpConfigPort"---                     , subForest = []---                     }---                 , Node---                     { rootLabel = "warpConfigTimeout"---                     , subForest = []---                     }---                 , Node---                     { rootLabel = "warpConfigHTTP2Enabled"---                     , subForest = []---                     }---                 , Node---                     { rootLabel = "warpConfigServerName"---                     , subForest = []---                     }---                 ]---             }---         , Node---             { rootLabel = "appConfigRedisSettings"---             , subForest =---                 [ Node---                     { rootLabel = "redisConfigHost"---                     , subForest = []---                     }---                 , Node---                     { rootLabel = "redisConfigPort"---                     , subForest = []---                     }---                 , Node---                     { rootLabel = "redisConfigConnectAuth"---                     , subForest = []---                     }---                 ]---             }---         , Node---             { rootLabel = "appConfigEnvironment"---             , subForest = []---             }---         ]---     }+    -- ** Initial configuration --- ** Parsing a representation------ |------ Below we are deriving just the parsers for our example data type from above.--- Just like the above example we use the 'RootConfig', 'SubConfig', and--- 'ConfigValue' types to derive the appropriate parsing classes. This time,--- however, there are 3 classes: 'RootParser' which should be placed on the top--- level configuration record, 'NestedParser' which should be derived for--- nested configuration product type, 'ValueParser' is derived for leaf level--- configuration values (you also need to derive 'NestedParser' for these, but--- there is a default method that just uses the 'ValueParser' so you can derive--- it without any strategy)------ More information on the parsers can be found at "Cfg.Parser".------ In the example below there is a term called @sample@ and this represents a--- tree that may have been retrieved from a source, and should be parsable--- given our type and derived instances.------ @--- {-# LANGUAGE DeriveGeneric #-}--- {-# LANGUAGE DerivingVia #-}------ import "Cfg.Deriving" (ConfigValue(..), SubConfig(..), ConfigRoot(..))--- import "Cfg.Parser" (RootParser(..), ConfigParseError, NestedParser, ValueParser)--- import Data.ByteString (ByteString)--- import Data.Text (Text)--- import GHC.Generics------ data Environment = Development | Production---   deriving stock (Generic, Show)---   deriving ('ValueParser') via ('ConfigValue' Environment)---   deriving 'NestedParser'------ data WarpConfig = WarpConfig---   { warpConfigPort :: Int---   , warpConfigTimeout :: Int---   , warpConfigHTTP2Enabled :: Bool---   , warpConfigServerName :: ByteString---   }---   deriving (Generic, Show)---   deriving ('NestedParser') via ('SubConfig' WarpConfig)------ data RedisConfig = RedisConfig---   { redisConfigHost :: Text---   , redisConfigPort :: Int---   , redisConfigConnectAuth :: Maybe ByteString---   }---   deriving (Generic, Show)---   deriving ('NestedParser') via ('SubConfig' RedisConfig)------ data AppConfig = AppConfig---   { appConfigWarpSettings :: WarpConfig---   , appConfigRedisSettings :: RedisConfig---   , appConfigEnvironment :: Environment---   }---   deriving stock (Generic, Show)---   deriving ('RootParser') via ('ConfigRoot' AppConfig)------ sample :: Tree Text--- sample = Node---     { rootLabel = \"AppConfig\"---     , subForest =---         [ Node---             { rootLabel = "appConfigWarpSettings"---             , subForest =---                 [ Node---                     { rootLabel = "warpConfigPort"---                     , subForest = [ Node "8080" [] ]---                     }---                 , Node---                     { rootLabel = "warpConfigTimeout"---                     , subForest = [ Node "30" [] ]---                     }---                 , Node---                     { rootLabel = "warpConfigHTTP2Enabled"---                     , subForest = [ Node \"True\" [] ]---                     }---                 , Node---                     { rootLabel = "warpConfigServerName"---                     , subForest = [ Node \"MyServer\" [] ]---                     }---                 ]---             }---         , Node---             { rootLabel = "appConfigRedisSettings"---             , subForest =---                 [ Node---                     { rootLabel = "redisConfigHost"---                     , subForest = [ Node "https://localhost" [] ]---                     }---                 , Node---                     { rootLabel = "redisConfigPort"---                     , subForest = [ Node "6379" [] ]---                     }---                 , Node---                     { rootLabel = "redisConfigConnectAuth"---                     , subForest = [ Node "Just password" [] ]---                     }---                 ]---             }---         , Node---             { rootLabel = "appConfigEnvironment"---             , subForest = [ Node \"Development\" [] ]---             }---         ]---     }--- @------ Here is a demonstration of running the parser on the sample tree structure--- shown above.------ >>> import Text.Pretty.Simple (pPrint) --- >>> import Cfg.Parser () -- Pulls in the RootParser instance for 'parseRootConfig'--- >>> pPrint $ parseRootConfig @AppConfig sample--- Right---     ( AppConfig---         { appConfigWarpSettings = WarpConfig---             { warpConfigPort = 8080---             , warpConfigTimeout = 30---             , warpConfigHTTP2Enabled = True---             , warpConfigServerName = "MyServer"---             }---         , appConfigRedisSettings = RedisConfig---             { redisConfigHost = "https://localhost"---             , redisConfigPort = 6379---             , redisConfigConnectAuth = Just "password"---             }---         , appConfigEnvironment = Development---         }---     )+    -- |+    --+    -- Let's start out with a couple types that represent some imaginary+    -- configuration for an imaginary application. This is the most basic+    -- kind of configuration we can have.+    --+    -- You will probably notice that records derive their instances via a+    -- `Config` newtype, while base types (types that represent the actual+    -- configuration values) are derived via a `Value` newtype. Values first+    -- derive a `ValueParser` instance, and then that makes it possible to+    -- derive a `ConfigParser` instance (no deriving via machinery necessary+    -- for that instance).+    --+    -- @+    -- {\-# LANGUAGE DeriveGeneric #-\}+    -- {\-# LANGUAGE DerivingVia #-\}+    --+    -- import "Cfg.Deriving.Config"+    -- import "Cfg.Deriving.Value"+    -- import "Cfg.Parser"+    -- import "Cfg.Source"+    -- import "Cfg.Source.Default"+    -- import Data.ByteString (ByteString)+    -- import GHC.Generics+    --+    -- data Environment = Development | Production+    --   deriving (Generic, Show, 'DefaultSource')+    --   deriving ('ConfigSource', 'ValueParser') via ('Value' Environment)+    --   -- Note: This is derivable via ConigParser's default instance, because we provided a ValueParser instance+    --   deriving ('ConfigParser')+    --+    -- data WarpConfig = WarpConfig+    --   { warpConfigPort :: Int+    --   , warpConfigTimeout :: Int+    --   , warpConfigHTTP2Enabled :: Bool+    --   , warpConfigServerName :: ByteString+    --   }+    --   deriving (Generic, Show, 'DefaultSource')+    --   deriving ('ConfigSource', 'ConfigParser') via ('Config' WarpConfig)+    --+    -- data RedisConfig = RedisConfig+    --   { redisConfigHost :: Text+    --   , redisConfigPort :: Int+    --   , redisConfigConnectAuth :: Maybe ByteString+    --   }+    --   deriving (Generic, Show, 'DefaultSource')+    --   deriving ('ConfigSource', 'ConfigParser') via ('Config' RedisConfig)+    --+    -- data AppConfig = AppConfig+    --   { appConfigWarpSettings :: WarpConfig+    --   , appConfigRedisSettings :: RedisConfig+    --   , appConfigEnvironment :: Environment+    --   }+    --   deriving (Generic, Show, 'DefaultSource')+    --   deriving ('ConfigSource', 'ConfigParser') via ('Config' AppConfig)+    -- @+    --+    -- And here is the result of generating the keys for this configuration setup+    --+    -- >>> import Cfg+    -- >>> import Text.Pretty.Simple+    -- >>> import Cfg.Env.Keys+    -- >>> pPrint $ showEnvKeys @AppConfig "_"+    -- [ "appConfigEnvironment"+    -- , "appConfigRedisSettings_redisConfigConnectAuth"+    -- , "appConfigRedisSettings_redisConfigHost"+    -- , "appConfigRedisSettings_redisConfigPort"+    -- , "appConfigWarpSettings_warpConfigHTTP2Enabled"+    -- , "appConfigWarpSettings_warpConfigPort"+    -- , "appConfigWarpSettings_warpConfigServerName"+    -- , "appConfigWarpSettings_warpConfigTimeout"+    -- ] --- ** Manipulating key format------ |------ The last thing we will go over is manipulating the way that we format--- configuration keys. Certain configuration sources have stylistic standards--- that may not be the same as Haskell. Therefore we offer some options for--- configuring their representation. ------ In the example below we will say that we are using environment variables as--- our configuration source. It is pretty standard to have env vars in--- SCREAMING_SNAKE_CASE, therefore we will apply a modifier that does that.------ We will also use a convenience function from "Cfg.Env.Keys" to print out--- the expected shape of the keys after all the formatters have been applied.------ @--- {-# LANGUAGE DeriveGeneric #-}--- {-# LANGUAGE DerivingVia #-}------ import "Cfg.Deriving" (ConfigValue(..), SubConfig(..), ConfigRoot(..))--- import "Cfg.Parser" (RootParser(..), ConfigParseError, NestedParser, ValueParser)--- import "Cfg.Deriving.LabelModifier" (ToUpper)--- import "Cfg.Deriving.ConfigRoot" (ConfigRootOpts(..))--- import "Cfg.Deriving.SubConfig" (SubConfigOpts(..))--- import Data.Text (Text)--- import Data.ByteString (ByteString)--- import GHC.Generics------ data Environment = Development | Production---   deriving stock (Generic, Show)---   deriving ('ValueParser') via ('ConfigValue' Environment)---   deriving 'NestedParser'------ data EnvWarpConfig = EnvWarpConfig---   { envWarpConfigPort :: Int---   , envWarpConfigTimeout :: Int---   , envWarpConfigHTTP2Enabled :: Bool---   , envWarpConfigServerName :: ByteString---   }---   deriving (Generic, Show)---   deriving ('NestedConfig') via ('SubConfigOpts' 'ToUpper' EnvWarpConfig)---   deriving ('NestedParser') via ('SubConfigOpts' 'ToUpper' EnvWarpConfig)------ data EnvRedisConfig = EnvRedisConfig---   { envRedisConfigHost :: Text---   , envRedisConfigPort :: Int---   , envRedisConfigConnectAuth :: Maybe ByteString---   }---   deriving (Generic, Show)---   deriving ('NestedConfig') via ('SubConfigOpts' 'ToUpper' EnvRedisConfig)---   deriving ('NestedParser') via ('SubConfigOpts' 'ToUpper' EnvRedisConfig)------ data EnvAppConfig = EnvAppConfig---   { envAppConfigWarpSettings :: EnvWarpConfig---   , envAppConfigRedisSettings :: EnvRedisConfig---   , envAppConfigEnvironment :: Environment---   }---   deriving stock (Generic, Show)---   deriving ('RootConfig') via ('ConfigRootOpts' 'ToUpper' 'ToUpper' EnvAppConfig)---   deriving ('RootParser') via ('ConfigRootOpts' 'ToUpper' 'ToUpper' EnvAppConfig)--- @------ >>> import Cfg--- >>> import Text.Pretty.Simple--- >>> import Cfg.Env.Keys--- >>> pPrint $ showEnvKeys @EnvAppConfig "_"--- [ "ENVAPPCONFIG_ENVAPPCONFIGWARPSETTINGS_ENVWARPCONFIGPORT"--- , "ENVAPPCONFIG_ENVAPPCONFIGWARPSETTINGS_ENVWARPCONFIGTIMEOUT"--- , "ENVAPPCONFIG_ENVAPPCONFIGWARPSETTINGS_ENVWARPCONFIGHTTP2ENABLED"--- , "ENVAPPCONFIG_ENVAPPCONFIGWARPSETTINGS_ENVWARPCONFIGSERVERNAME"--- , "ENVAPPCONFIG_ENVAPPCONFIGREDISSETTINGS_ENVREDISCONFIGHOST"--- , "ENVAPPCONFIG_ENVAPPCONFIGREDISSETTINGS_ENVREDISCONFIGPORT"--- , "ENVAPPCONFIG_ENVAPPCONFIGREDISSETTINGS_ENVREDISCONFIGCONNECTAUTH"--- , "ENVAPPCONFIG_ENVAPPCONFIGENVIRONMENT"--- ]+    -- ** Basic key modifiers --- * Exports------ |---+    -- |+    --+    -- This is okay, but there are some changes we may want to make. We will go+    -- through a series of tweaks to the example above to format the keys. We+    -- format the keys by providing formatting options through a new newtype+    -- 'ConfigOpts' that accepts a type parameter.+    --+    -- @+    -- data WarpConfig = ...+    --   deriving (Generic, Show, 'DefaultSource')+    --   deriving ('ConfigSource', 'ConfigParser') via ('ConfigOpts' 'ToUpper' WarpConfig)+    --+    -- data RedisConfig = ...+    --   deriving (Generic, Show, 'DefaultSource')+    --   deriving ('ConfigSource', 'ConfigParser') via ('ConfigOpts' 'ToUpper' WarpConfig)+    --+    -- data AppConfig = ...+    --   deriving (Generic, Show, 'DefaultSource')+    --   deriving ('ConfigSource', 'ConfigParser') via ('ConfigOpts' 'ToUpper' AppConfig)+    -- @+    --+    -- Let's print the keys out again (note, we have to add a numbered suffix+    -- to the constructor so we don't get namespace collisions in the doc+    -- tests)+    --+    -- >>> import Cfg+    -- >>> import Text.Pretty.Simple+    -- >>> import Cfg.Env.Keys+    -- >>> pPrint $ showEnvKeys @AppConfig2 "_"+    -- [ "APPCONFIGENVIRONMENT"+    -- , "APPCONFIGREDISSETTINGS_REDISCONFIGCONNECTAUTH"+    -- , "APPCONFIGREDISSETTINGS_REDISCONFIGHOST"+    -- , "APPCONFIGREDISSETTINGS_REDISCONFIGPORT"+    -- , "APPCONFIGWARPSETTINGS_WARPCONFIGHTTP2ENABLED"+    -- , "APPCONFIGWARPSETTINGS_WARPCONFIGPORT"+    -- , "APPCONFIGWARPSETTINGS_WARPCONFIGSERVERNAME"+    -- , "APPCONFIGWARPSETTINGS_WARPCONFIGTIMEOUT"+    -- ] -  getConfigRaw,-  getConfig,-) where+    -- ** Multiple key modifiers +    -- |+    --+    -- This is close, but we probably want to remove the record field suffixes+    -- for our configuration. We can provide more than one formatter through+    -- tuples (up to a cardinality of 4) or a type level list. These formatters+    -- apply in order from left to right.+    --+    -- @+    -- data WarpConfig = WarpConfig+    --   { warpConfigPort :: Int+    --   , warpConfigTimeout :: Int+    --   , warpConfigHTTP2Enabled :: Bool+    --   , warpConfigServerName :: ByteString+    --   }+    --   deriving (Generic, Show, 'DefaultSource')+    --   deriving ('ConfigSource', 'ConfigParser') via ('ConfigOpts' ('StripPrefix' "warpConfig", 'ToUpper') WarpConfig)+    --+    -- data RedisConfig = RedisConfig+    --   { redisConfigHost :: Text+    --   , redisConfigPort :: Int+    --   , redisConfigConnectAuth :: Maybe ByteString+    --   }+    --   deriving (Generic, Show, 'DefaultSource')+    --   deriving ('ConfigSource', 'ConfigParser') via ('ConfigOpts' ['StripPrefix' "redisConfig", 'ToUpper'] WarpConfig)+    --+    -- data AppConfig = AppConfig+    --   { appConfigWarpSettings :: WarpConfig+    --   , appConfigRedisSettings :: RedisConfig+    --   , appConfigEnvironment :: Environment+    --   }+    --   deriving (Generic, Show, 'DefaultSource')+    --   deriving ('ConfigSource', 'ConfigParser')+    --    via ('ConfigOpts' ['StripPrefix' "appConfig", 'StripSuffix' \"Settings\", ToUpper] AppConfig)+    -- @+    --+    -- >>> import Cfg+    -- >>> import Text.Pretty.Simple+    -- >>> import Cfg.Env.Keys+    -- >>> pPrint $ showEnvKeys @AppConfig3 "_"+    -- [ "ENVIRONMENT"+    -- , "REDIS_CONNECTAUTH"+    -- , "REDIS_HOST"+    -- , "REDIS_PORT"+    -- , "WARP_HTTP2ENABLED"+    -- , "WARP_PORT"+    -- , "WARP_SERVERNAME"+    -- , "WARP_TIMEOUT"+    -- ] -import Data.Text (Text)-import Data.Tree (Tree (..))-import Cfg.Source (RootConfig(..), FetchSource, NestedConfig)-import Cfg.Parser (RootParser(..), ConfigParseError, NestedParser, ValueParser)-import Cfg.Deriving (ConfigValue(..), ConfigRoot(..))+    -- ** Root key --- Imports for examples-import GHC.Generics+    -- |+    --+    -- This is much better, but we might even want to go a step further and+    -- namespace our config with a rootkey. We can do this by deriving via a+    -- special type on our root config record.+    --+    -- @+    -- data AppConfig = AppConfig+    --   { appConfigWarpSettings :: WarpConfig+    --   , appConfigRedisSettings :: RedisConfig+    --   , appConfigEnvironment :: Environment+    --   }+    -- deriving (Generic, Show, 'DefaultSource')+    -- deriving ('ConfigSource', 'ConfigParser')+    --   via (+    --     'ConfigRoot'+    --       (''TypeName' ['StripSuffix' "Config", 'ToUpper'])+    --       ['StripPrefix' "appConfig", 'StripSuffix' \"Settings\", 'ToUpper']+    --       AppConfig+    --   )+    -- @+    --+    -- The first parameter to 'ConfigRoot' is either 'TypeName' or+    -- 'ConstructorName', this indicates which name will be used for the root+    -- key. You can then provide key formatters to manipulate that name.+    --+    -- >>> import Cfg+    -- >>> import Text.Pretty.Simple+    -- >>> import Cfg.Env.Keys+    -- >>> pPrint $ showEnvKeys @AppConfig4 "_"+    -- [ "APP_ENVIRONMENT"+    -- , "APP_REDIS_CONNECTAUTH"+    -- , "APP_REDIS_HOST"+    -- , "APP_REDIS_PORT"+    -- , "APP_WARP_HTTP2ENABLED"+    -- , "APP_WARP_PORT"+    -- , "APP_WARP_SERVERNAME"+    -- , "APP_WARP_TIMEOUT"+    -- ]++    -- ** Defaults++    -- |+    --+    -- The defaulting machinery is admittedly a bit crude. You must define a+    -- 'DefaultSource' instance for the record that contains the value you want+    -- to default. The reason the defaulting needs to be defined on the record+    -- is that we use the record field key to identify the defaulted value the+    -- value you want to default. The reason the defaulting needs to be defined+    -- on the record is that we use the record field key to identify the+    -- defaulted value.+    --+    -- __There are a bunch of gotchas with defaulting__:+    --+    --    - Since the type of 'defaults' is @Text -> Maybe Text@, the onus is+    --    on the implementor to make sure that this function correctly matches+    --    the record field name.+    --+    --    - The way it is currently implemented we use the 'defaults' function+    --    on the record field /before/ applying key modifiers.+    --+    --    - If there is a mismatch it will fail silently by not defaulting.+    --    This may result in an error when parsing (due to a missing value).+    --+    --    - You can only set defaults via their textual representation, so your+    --    defaults might fail to parse!+    --+    --    - If you declare a default on a field that is supposed to hold nested config this will break, and there is nothing at the type level to prevent you from making this mistake+    --+    -- Considering all of the above, it may be preferable to do some defaulting+    -- on the configuration side (i.e. make sure default environment variables+    -- are set, or provide default configuration files that can be modified).+    --+    -- If you still want to do defaulting on the haskell side here is how:+    --+    -- @+    -- data AppConfig = AppConfig+    --   { appConfigWarpSettings :: WarpConfig+    --   , appConfigRedisSettings :: RedisConfig+    --   , appConfigEnvironment :: Environment+    --   }+    --   deriving (Generic, Show)+    --   deriving ('ConfigSource', 'ConfigParser')+    --    via ('ConfigOpts' ['StripPrefix' "appConfig", 'StripSuffix' \"Settings\", ToUpper] AppConfig)+    --+    -- -- NOTE: If I provide a default for WarpConfig or RedisConfig this will break the configuration machinery+    -- -- so I only match on the field for @Environment@+    --+    -- instance 'DefaultSource' (AppConfig a) where+    --   'defaults' "appConfigEnvironment" = Just "Development"+    --   'defaults' _ = Nothing+    -- @++    -- * Exports+    getConfigRaw+  , getConfig+  )+where++-- Haddock example imports++import Cfg.Deriving+import Cfg.Options+import Cfg.Parser+import Cfg.Parser ()+import Cfg.Source+import Cfg.Source ()+import Cfg.Source.Default import Data.ByteString (ByteString)-import Cfg.Deriving.SubConfig (SubConfig(..))-import Cfg.Deriving.LabelModifier (ToUpper)-import Cfg.Deriving.ConfigRoot (ConfigRootOpts(..))-import Cfg.Deriving.SubConfig (SubConfigOpts(..))+import Data.Text (Text)+import GHC.Generics+import KeyTree  -- | @since 0.0.1.0-getConfigRaw ::-    Monad m =>-    Tree Text ->-    (Tree Text -> m (Tree Text)) ->-    (Tree Text -> Either e a) ->-    m (Either e a)-getConfigRaw keyTree source parser = parser <$> source keyTree+getConfigRaw+  :: (Monad m)+  => KeyTree Text Text+  -> (KeyTree Text Text -> m (KeyTree Text Text))+  -> (KeyTree Text Text -> Either e a)+  -> m (Either e a)+getConfigRaw keyTree source parse = parse <$> source keyTree  -- | @since 0.0.1.0-getConfig :: forall a m . (Monad m, RootConfig a, RootParser a) => FetchSource m -> m (Either ConfigParseError a)-getConfig fetch = parseRootConfig @a <$> fetch (toRootConfig @a)-+getConfig+  :: forall a m+   . (Monad m, ConfigSource a, ConfigParser a)+  => FetchSource m+  -> m (Either ConfigParseError a)+getConfig fetch = parseConfig @a <$> fetch (configSource @a)  ------------------------------------------------------- -- Examples for haddocks ------------------------------------------------------- data Environment = Development | Production-  deriving stock (Generic, Show)-  deriving (NestedConfig) via ConfigValue Environment-  deriving (ValueParser) via ConfigValue Environment-  deriving NestedParser+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource, ValueParser) via (Value Environment)+  deriving (ConfigParser) -- Note: This is derivable via ConigParser's default instance, because we provided a ValueParser instance +-- Example 1+ data WarpConfig = WarpConfig   { warpConfigPort :: Int   , warpConfigTimeout :: Int   , warpConfigHTTP2Enabled :: Bool   , warpConfigServerName :: ByteString   }-  deriving (Generic, Show)-  deriving (NestedConfig) via (SubConfig WarpConfig)-  deriving (NestedParser) via (SubConfig WarpConfig)+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource, ConfigParser) via (Config WarpConfig)  data RedisConfig = RedisConfig   { redisConfigHost :: Text   , redisConfigPort :: Int   , redisConfigConnectAuth :: Maybe ByteString   }-  deriving (Generic, Show)-  deriving (NestedConfig) via (SubConfig RedisConfig)-  deriving (NestedParser) via (SubConfig RedisConfig)+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource, ConfigParser) via (Config RedisConfig)  data AppConfig = AppConfig   { appConfigWarpSettings :: WarpConfig   , appConfigRedisSettings :: RedisConfig   , appConfigEnvironment :: Environment   }-  deriving stock (Generic, Show)-  deriving (RootConfig) via (ConfigRoot AppConfig)-  deriving (RootParser) via (ConfigRoot AppConfig)+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource, ConfigParser) via (Config AppConfig) -sample :: Tree Text-sample = Node-    { rootLabel = "AppConfig"-    , subForest =-        [ Node-            { rootLabel = "appConfigWarpSettings"-            , subForest =-                [ Node-                    { rootLabel = "warpConfigPort"-                    , subForest = [ Node "8080" [] ]-                    }-                , Node-                    { rootLabel = "warpConfigTimeout"-                    , subForest = [ Node "30" [] ]-                    }-                , Node-                    { rootLabel = "warpConfigHTTP2Enabled"-                    , subForest = [ Node "True" [] ]-                    }-                , Node-                    { rootLabel = "warpConfigServerName"-                    , subForest = [ Node "MyServer" [] ]-                    }-                ]-            }-        , Node-            { rootLabel = "appConfigRedisSettings"-            , subForest =-                [ Node-                    { rootLabel = "redisConfigHost"-                    , subForest = [ Node "https://localhost" [] ]-                    }-                , Node-                    { rootLabel = "redisConfigPort"-                    , subForest = [ Node "6379" [] ]-                    }-                , Node-                    { rootLabel = "redisConfigConnectAuth"-                    , subForest = [ Node "Just password" [] ]-                    }-                ]-            }-        , Node-            { rootLabel = "appConfigEnvironment"-            , subForest = [ Node "Development" [] ]-            }-        ]-    }+-- Example 2+data WarpConfig2 = WarpConfig2+  { warpConfigPort :: Int+  , warpConfigTimeout :: Int+  , warpConfigHTTP2Enabled :: Bool+  , warpConfigServerName :: ByteString+  }+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource, ConfigParser) via (ConfigOpts ToUpper WarpConfig2) -data EnvWarpConfig = EnvWarpConfig-  { envWarpConfigPort :: Int-  , envWarpConfigTimeout :: Int-  , envWarpConfigHTTP2Enabled :: Bool-  , envWarpConfigServerName :: ByteString+data RedisConfig2 = RedisConfig2+  { redisConfigHost :: Text+  , redisConfigPort :: Int+  , redisConfigConnectAuth :: Maybe ByteString   }-  deriving (Generic, Show)-  deriving (NestedConfig) via (SubConfigOpts ToUpper EnvWarpConfig)-  deriving (NestedParser) via (SubConfigOpts ToUpper EnvWarpConfig)+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource, ConfigParser) via (ConfigOpts ToUpper RedisConfig2) -data EnvRedisConfig = EnvRedisConfig-  { envRedisConfigHost :: Text-  , envRedisConfigPort :: Int-  , envRedisConfigConnectAuth :: Maybe ByteString+data AppConfig2 = AppConfig2+  { appConfigWarpSettings :: WarpConfig2+  , appConfigRedisSettings :: RedisConfig2+  , appConfigEnvironment :: Environment   }-  deriving (Generic, Show)-  deriving (NestedConfig) via (SubConfigOpts ToUpper EnvRedisConfig)-  deriving (NestedParser) via (SubConfigOpts ToUpper EnvRedisConfig)+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource, ConfigParser) via (ConfigOpts ToUpper AppConfig2) -data EnvAppConfig = EnvAppConfig-  { envAppConfigWarpSettings :: EnvWarpConfig-  , envAppConfigRedisSettings :: EnvRedisConfig-  , envAppConfigEnvironment :: Environment+-- Example 3+data WarpConfig3 = WarpConfig3+  { warpConfigPort :: Int+  , warpConfigTimeout :: Int+  , warpConfigHTTP2Enabled :: Bool+  , warpConfigServerName :: ByteString   }-  deriving stock (Generic, Show)-  deriving (RootConfig) via (ConfigRootOpts ToUpper ToUpper EnvAppConfig)-  deriving (RootParser) via (ConfigRootOpts ToUpper ToUpper EnvAppConfig)+  deriving (Generic, Show, DefaultSource)+  deriving+    (ConfigSource, ConfigParser)+    via (ConfigOpts (StripPrefix "warpConfig", ToUpper) WarpConfig3)++data RedisConfig3 = RedisConfig3+  { redisConfigHost :: Text+  , redisConfigPort :: Int+  , redisConfigConnectAuth :: Maybe ByteString+  }+  deriving (Generic, Show, DefaultSource)+  deriving+    (ConfigSource, ConfigParser)+    via (ConfigOpts [StripPrefix "redisConfig", ToUpper] RedisConfig3)++data AppConfig3 = AppConfig3+  { appConfigWarpSettings :: WarpConfig3+  , appConfigRedisSettings :: RedisConfig3+  , appConfigEnvironment :: Environment+  }+  deriving (Generic, Show, DefaultSource)+  deriving+    (ConfigSource, ConfigParser)+    via (ConfigOpts [StripPrefix "appConfig", StripSuffix "Settings", ToUpper] AppConfig3)++-- Example 4+data AppConfig4 = AppConfig4+  { appConfigWarpSettings :: WarpConfig3+  , appConfigRedisSettings :: RedisConfig3+  , appConfigEnvironment :: Environment+  }+  deriving (Generic, Show, DefaultSource)+  deriving+    (ConfigSource, ConfigParser)+    via ( ConfigRoot+            ('TypeName [StripSuffix "Config4", ToUpper])+            [StripPrefix "appConfig", StripSuffix "Settings", ToUpper]+            AppConfig4+        )

@@ -1,12 +1,21 @@+-- |+--  Module      : Cfg.Deriving+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- Convenience module that re-exports all the necessary bits for deriving+-- instances. module Cfg.Deriving-  ( module Cfg.Deriving.ConfigRoot-  , module Cfg.Deriving.ConfigValue-  , module Cfg.Deriving.SubConfig-  , module Cfg.Deriving.LabelModifier+  ( module Cfg.Deriving.Config+  , module Cfg.Deriving.Value+  , module Cfg.Deriving.KeyModifier   ) where -import Cfg.Deriving.ConfigRoot-import Cfg.Deriving.ConfigValue-import Cfg.Deriving.LabelModifier-import Cfg.Deriving.SubConfig+import Cfg.Deriving.Config+import Cfg.Deriving.KeyModifier+import Cfg.Deriving.Value

@@ -1,3 +1,14 @@+-- |+--  Module      : Cfg.Deriving.Assert+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module provides type level assertions so that we can constrain the+-- instances user's can create, and give them good error messages module Cfg.Deriving.Assert where  import Data.Kind (Type)@@ -5,25 +16,40 @@ import GHC.Generics import GHC.TypeError (ErrorMessage (..), TypeError) +-- | A type level helper for creating custom error messages based on a predicate+--+-- @since 0.0.2.0 class Assert (pred :: Bool) (msg :: ErrorMessage)+ instance Assert 'True msg-instance TypeError msg ~ '() => Assert 'False msg +instance (TypeError msg ~ '()) => Assert 'False msg++-- | A type level predicate that helps us identify top level product types+--+-- @since 0.0.2.0 type family IsTopLevelRecord f where-    IsTopLevelRecord V1 = 'False-    IsTopLevelRecord U1 = 'False-    IsTopLevelRecord (K1 i c) = 'False-    IsTopLevelRecord (M1 i c f) = IsTopLevelRecord f-    IsTopLevelRecord (f :*: g) = 'True-    IsTopLevelRecord (f :+: g) = 'False+  IsTopLevelRecord V1 = 'False+  IsTopLevelRecord U1 = 'False+  IsTopLevelRecord (K1 i c) = 'False+  IsTopLevelRecord (M1 D c f) = IsTopLevelRecord f+  IsTopLevelRecord (M1 C c f) = IsTopLevelRecord f+  IsTopLevelRecord (M1 S c f) = 'True+  IsTopLevelRecord (f :*: g) = IsTopLevelRecord f+  IsTopLevelRecord (f :+: g) = 'False +-- | A custom error message for non-top-level records+--+-- @since 0.0.2.0 type AssertTopLevelRecord (constraint :: Type -> Constraint) a =-    Assert-        (IsTopLevelRecord (Rep a))-        ( 'Text "🚫 Cannot derive "-            ':<>: 'ShowType constraint-            ':<>: 'Text " instance for "-            ':<>: 'ShowType a-            ':<>: 'Text " via ConfigRoot"-            ':$$: 'Text "💡 ConfigRoot must be derived on a top level record type with named fields."-        )+  Assert+    (IsTopLevelRecord (Rep a))+    ( 'Text "🚫 Cannot derive "+        ':<>: 'ShowType constraint+        ':<>: 'Text " instance for "+        ':<>: 'ShowType a+        ':$$: ( 'Text "💡 "+                  ':<>: 'ShowType constraint+                  ':<>: 'Text " must be derived on a top level record type with named fields."+              )+    )

@@ -0,0 +1,348 @@+-- |+--  Module      : Cfg.Deriving.Config+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module provides types and instances for deriving 'ConfigSource' and+-- 'ConfigParser' instances via generic machinery. These types are also how you+-- modify the key representation for your configuration.+module Cfg.Deriving.Config+  ( -- * Deriving Types+    Config (..)+  , ConfigOpts (..)+  , ConfigRoot (..)++    -- * Internal Typeclasses+  , GetConfigOptions (..)+  , ConfigRootOptions (..)+  )+where++import Cfg.Deriving.Assert (AssertTopLevelRecord)+import Cfg.Deriving.KeyModifier+import Cfg.Options+import Cfg.Parser+import Cfg.Parser.Config+import Cfg.Source+import Cfg.Source.Config+import Cfg.Source.Default+import Data.Coerce+import GHC.Generics++-- $setup+-- >>> import GHC.Generics (Generic (..))+-- >>> import Cfg.Source (ConfigSource(..))+-- >>> import Cfg.Parser (ConfigParser(..))+-- >>> import Text.Pretty.Simple++-- | This newtype is the simplest deriving option. It doesn't allow you to+-- alter key names with a 'Cfg.Deriving.KeyModifier.KeyModifier', it only+-- specifies record fields as keys within the configuration tree hierarchy.+-- Therefore it is not possible to derive this for configuration /values/ (such+-- as product types without named record fields, or sum types), only top level+-- records.+--+-- ===== __Example__+--+-- >>> import GHC.Generics (Generic (..))+-- >>> import Cfg.Source (ConfigSource(..))+-- >>> import Cfg.Parser (ConfigParser(..))+-- >>> import Cfg.Deriving.Config (Config(..))+-- >>> import Cfg.Source.Default (DefaultSource(..))+-- >>> :{+-- data AppConfig = AppConfig+--   { appConfigSetting1 :: Int+--   , appConfigSetting2 :: Bool+--   , appConfigSetting3 :: String+--   }+--   deriving (Generic, Show, DefaultSource)+--   deriving (ConfigSource, ConfigParser) via (Config AppConfig)+-- :}+--+-- >>> pPrint $ configSource @AppConfig+-- Free+--     ( fromList+--         [+--             ( "appConfigSetting1"+--             , Free+--                 ( fromList [] )+--             )+--         ,+--             ( "appConfigSetting2"+--             , Free+--                 ( fromList [] )+--             )+--         ,+--             ( "appConfigSetting3"+--             , Free+--                 ( fromList [] )+--             )+--         ]+--     )+--+-- @since 0.0.2.0+newtype Config a = Config {unConfig :: a}++-- | @since 0.0.2.0+instance (Generic a) => Generic (Config a) where+  type Rep (Config a) = Rep a+  to = Config . to+  from (Config x) = from x++-- | This newtype is identical to 'Config' except that it accepts a type+-- argument which can be used to apply a 'Cfg.Deriving.KeyModifier.KeyModifier'+-- to each record field name when generating keys.+--+-- ===== __Example__+--+-- >>> import GHC.Generics (Generic (..))+-- >>> import Cfg.Source (ConfigSource(..))+-- >>> import Cfg.Parser (ConfigParser(..))+-- >>> import Cfg.Deriving.Config (Config(..))+-- >>> import Cfg.Source.Default (DefaultSource(..))+-- >>> :{+-- data AppConfig = AppConfig+--   { appConfigSetting1 :: Int+--   , appConfigSetting2 :: Bool+--   , appConfigSetting3 :: String+--   }+--   deriving (Generic, Show, DefaultSource)+--   deriving (ConfigSource, ConfigParser)+--      via (ConfigOpts '[StripPrefix "app", CamelToSnake, ToUpper] AppConfig)+-- :}+--+-- >>> pPrint $ configSource @AppConfig+-- Free+--     ( fromList+--         [+--             ( "CONFIG_SETTING1"+--             , Free+--                 ( fromList [] )+--             )+--         ,+--             ( "CONFIG_SETTING2"+--             , Free+--                 ( fromList [] )+--             )+--         ,+--             ( "CONFIG_SETTING3"+--             , Free+--                 ( fromList [] )+--             )+--         ]+--     )+--+-- @since 0.0.2.0+newtype ConfigOpts fieldModifier a = ConfigOpts {unConfigOptions :: a}++-- | @since 0.0.2.0+instance (Generic a) => Generic (ConfigOpts t a) where+  type Rep (ConfigOpts t a) = Rep a+  to = ConfigOpts . to+  from (ConfigOpts x) = from x++-- | This newtype is used to derive instances for your root configuration type+-- (i.e. the top level record for all your configuration). The only additional+-- functionality that it provides is that it lets you specify a root key, which+-- is derived from either the type name or the data constructor name. You+-- choose which name you select by providing either+-- 'Cfg.Options.ConstructorName` or 'Cfg.Options.TypeName' as the first type+-- argument to `ConfigRoot`. These `Cfg.Options.RootKey` types also take a type+-- level argument where you can provide key modifiers, if you don't want to+-- apply any key modifiers you can pass in 'Cfg.Deriving.KeyModifier.Identity'+-- or an empty tuple or an empty type level list.+--+-- ===== __@TypeName@ Example__+--+-- >>> import GHC.Generics (Generic (..))+-- >>> import Cfg.Source (ConfigSource(..))+-- >>> import Cfg.Parser (ConfigParser(..))+-- >>> import Cfg.Deriving.Config (Config(..))+-- >>> import Cfg.Source.Default (DefaultSource(..))+-- >>> import Cfg.Deriving.KeyModifier+-- >>> :{+-- data TypeNameConfig = ConfigConstructor+--   { appConfigSetting1 :: Int+--   , appConfigSetting2 :: Bool+--   , appConfigSetting3 :: String+--   }+--   deriving (Generic, Show, DefaultSource)+--   deriving (ConfigSource, ConfigParser)+--      via ConfigRoot+--        ('TypeName '[StripSuffix "Config", CamelToSnake, ToUpper])+--        '[StripPrefix "app", CamelToSnake, ToUpper]+--        TypeNameConfig+-- :}+--+-- >>> pPrint $ configSource @TypeNameConfig+-- Free+--     ( fromList+--         [+--             ( "TYPE_NAME"+--             , Free+--                 ( fromList+--                     [+--                         ( "CONFIG_SETTING1"+--                         , Free+--                             ( fromList [] )+--                         )+--                     ,+--                         ( "CONFIG_SETTING2"+--                         , Free+--                             ( fromList [] )+--                         )+--                     ,+--                         ( "CONFIG_SETTING3"+--                         , Free+--                             ( fromList [] )+--                         )+--                     ]+--                 )+--             )+--         ]+--     )+--+-- ===== __@ConstructorName@ Example__+--+-- >>> :{+-- data TypeNameConfig = ConfigConstructor+--   { appConfigSetting1 :: Int+--   , appConfigSetting2 :: Bool+--   , appConfigSetting3 :: String+--   }+--   deriving (Generic, Show, DefaultSource)+--   deriving (ConfigSource, ConfigParser)+--      via ConfigRoot+--        ('ConstructorName Identity)+--        '[StripPrefix "app", CamelToSnake, ToUpper]+--        TypeNameConfig+-- :}+--+-- >>> pPrint $ configSource @TypeNameConfig+-- Free+--     ( fromList+--         [+--             ( "ConfigConstructor"+--             , Free+--                 ( fromList+--                     [+--                         ( "CONFIG_SETTING1"+--                         , Free+--                             ( fromList [] )+--                         )+--                     ,+--                         ( "CONFIG_SETTING2"+--                         , Free+--                             ( fromList [] )+--                         )+--                     ,+--                         ( "CONFIG_SETTING3"+--                         , Free+--                             ( fromList [] )+--                         )+--                     ]+--                 )+--             )+--         ]+--     )+--+-- @since 0.0.2.0+newtype ConfigRoot rootType fieldModifier a = ConfigRoot {unConfigRoot :: a}++-- | Typeclass for reifying type level field label modifiers into 'Cfg.Options.KeyOptions'+--+-- @since 0.0.2.0+class (KeyModifier t) => GetConfigOptions t where+  getOptions :: KeyOptions++-- | @since 0.0.2.0+instance (KeyModifier t) => GetConfigOptions t where+  getOptions = KeyOptions (getKeyModifier @t)++-- | @since 0.0.2.0+instance (Generic a) => Generic (ConfigRoot r f a) where+  type Rep (ConfigRoot r f a) = Rep a+  to = ConfigRoot . to+  from (ConfigRoot x) = from x++-- | Typeclass for reifying type level arguments into 'Cfg.Options.RootOptions'+--+-- @since 0.0.2.0+class (KeyModifier r, KeyModifier f) => ConfigRootOptions r f where+  configRootOptions :: RootOptions++-- | @since 0.0.2.0+instance (KeyModifier (TypeName k), KeyModifier f) => ConfigRootOptions (TypeName k) f where+  configRootOptions = RootOptions (TypeName $ getKeyModifier @(TypeName k)) (getKeyModifier @f)++-- | @since 0.0.2.0+instance (KeyModifier (ConstructorName k), KeyModifier f) => ConfigRootOptions (ConstructorName k) f where+  configRootOptions = RootOptions (ConstructorName $ getKeyModifier @(ConstructorName k)) (getKeyModifier @f)++-- Source++-- | @since 0.0.2.0+instance+  (AssertTopLevelRecord ConfigSource a, DefaultSource a, Generic a, GConfigSource (Rep a))+  => ConfigSource (Config a)+  where+  configSource = defaultConfigSource @a defaultConfigOptions++-- | @since 0.0.2.0+instance+  ( GetConfigOptions t+  , AssertTopLevelRecord ConfigSource a+  , Generic a+  , DefaultSource a+  , GConfigSource (Rep a)+  )+  => ConfigSource (ConfigOpts t a)+  where+  configSource = defaultConfigSource @a (Key $ getOptions @t)++-- | @since 0.0.2.0+instance+  ( ConfigRootOptions r f+  , AssertTopLevelRecord ConfigSource a+  , Generic a+  , DefaultSource a+  , GConfigSource (Rep a)+  )+  => ConfigSource (ConfigRoot r f a)+  where+  configSource = defaultConfigSource @a (Root $ configRootOptions @r @f)++-- Parser++-- | @since 0.0.2.0+instance+  (AssertTopLevelRecord ConfigParser a, Generic a, GConfigParser (Rep a))+  => ConfigParser (Config a)+  where+  parseConfig keyTree = coerce `asTypeOf` fmap Config $ defaultParseConfig defaultConfigOptions keyTree++-- | @since 0.0.2.0+instance+  ( GetConfigOptions t+  , AssertTopLevelRecord ConfigSource a+  , Generic a+  , GConfigParser (Rep a)+  )+  => ConfigParser (ConfigOpts t a)+  where+  parseConfig keyTree = coerce `asTypeOf` fmap ConfigOpts $ defaultParseConfig (Key $ getOptions @t) keyTree++-- | @since 0.0.2.0+instance+  ( ConfigRootOptions r f+  , AssertTopLevelRecord ConfigParser a+  , Generic a+  , GConfigParser (Rep a)+  )+  => ConfigParser (ConfigRoot r f a)+  where+  parseConfig keyTree = coerce `asTypeOf` fmap ConfigRoot $ defaultParseConfig (Root $ configRootOptions @r @f) keyTree

@@ -1,52 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-module Cfg.Deriving.ConfigRoot where--import Cfg.Deriving.Assert (AssertTopLevelRecord)-import Cfg.Deriving.LabelModifier (LabelModifier (..))-import Cfg.Options (ConfigOptions (..), RootOptions (..), defaultRootOptions)-import Cfg.Source (RootConfig (..))-import Cfg.Source.RootConfig (GConfigTree, defaultToRootConfig)-import GHC.Generics-import Cfg.Parser.ConfigParser-import Cfg.Parser (RootParser (..))-import Data.Coerce--newtype ConfigRoot a = ConfigRoot {unConfigRoot :: a}--instance Generic a => Generic (ConfigRoot a) where-    type Rep (ConfigRoot a) = Rep a-    to = ConfigRoot . to-    from (ConfigRoot x) = from x--newtype ConfigRootOpts t t' a = ConfigRootOpts {unConfigRootOpts :: a}--instance Generic a => Generic (ConfigRootOpts t t' a) where-    type Rep (ConfigRootOpts t t' a) = Rep a-    to = ConfigRootOpts . to-    from (ConfigRootOpts x) = from x--class (LabelModifier t, LabelModifier t') => GetConfigRootOptions t t' where-    getConfigRootOptions :: RootOptions--instance (LabelModifier t, LabelModifier t') => GetConfigRootOptions t t' where-    getConfigRootOptions = RootOptions (getLabelModifier @t) (ConfigOptions $ getLabelModifier @t')---- Source-instance (AssertTopLevelRecord RootConfig a, Generic a, GConfigTree (Rep a)) => RootConfig (ConfigRoot a) where-    toRootConfig = defaultToRootConfig @a defaultRootOptions--instance (LabelModifier t, LabelModifier t', AssertTopLevelRecord RootConfig a, Generic a, GConfigTree (Rep a)) => RootConfig (ConfigRootOpts t t' a) where-    toRootConfig = defaultToRootConfig @a (getConfigRootOptions @t @t')---- Parser-instance (AssertTopLevelRecord RootConfig a, Generic a, GRootConfigParser (Rep a)) => RootParser (ConfigRoot a) where-  parseRootConfig tree = coerce `asTypeOf` fmap ConfigRoot $ defaultParseRootConfig defaultRootOptions tree--instance-  ( LabelModifier t-  , LabelModifier t'-  , AssertTopLevelRecord RootConfig a-  , Generic a-  , GRootConfigParser (Rep a)-  ) => RootParser (ConfigRootOpts t t' a) where-    parseRootConfig tree = coerce `asTypeOf` fmap ConfigRootOpts $ defaultParseRootConfig (getConfigRootOptions @t @t') tree

@@ -1,19 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-module Cfg.Deriving.ConfigValue where--import GHC.Generics-import Cfg.Parser.ValueParser-import Cfg.Parser-import Data.Coerce--newtype ConfigValue a = ConfigValue {unConfigValue :: a}--instance Generic a => Generic (ConfigValue a) where-    type Rep (ConfigValue a) = Rep a-    to = ConfigValue . to-    from (ConfigValue x) = from x--instance (Generic a, GValueParser (Rep a)) => ValueParser (ConfigValue a) where-    parser = coerce `asTypeOf` fmap ConfigValue $ defaultValueParser @a--instance (Generic a, GValueParser (Rep a)) => NestedParser (ConfigValue a)

@@ -0,0 +1,198 @@+-- |+--  Module      : Cfg.Deriving.KeyModifier+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module provides type level tags that can be used to configure string+-- transformations against configuration keys derived from things like record+-- fields.+module Cfg.Deriving.KeyModifier+  ( -- * Key Modifiers+    KeyModifier (..)+  , Identity+  , ToLower+  , ToUpper+  , LowerFirst+  , UpperFirst+  , StripPrefix+  , StripSuffix+  , CamelTo+  , CamelToSnake+  , CamelToKebab++    -- * Helper Functions+  , mapFirst+  , camelTo+  , camelToText+  )+where++import Cfg.Options (RootKey (..))+import Data.Char (isLower, isUpper, toLower, toUpper)+import Data.Data (Proxy (..))+import Data.Functor+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.TypeLits++-- | Identity transformation, corresponds to 'id', does not change the string.+--+-- @since 0.0.2.0+data Identity++-- | Lower cases all alphabetical characters, corresponds to 'Data.Text.toLower'.+--+-- @since 0.0.2.0+data ToLower++-- | Upper cases all alphabetical characters, corresponds to 'Data.Text.toUpper'.+--+-- @since 0.0.2.0+data ToUpper++-- | Lower cases the first character, corresponds to 'Data.Char.toLower'.+--+-- @since 0.0.2.0+data LowerFirst++-- | Upper cases the first character, corresponds to 'Data.Char.toUpper'.+--+-- @since 0.0.2.0+data UpperFirst++-- | Takes a type level string and removes that from the beginning of the text,+-- corresponds to 'Data.Text.stripPrefix'.+--+-- @since 0.0.2.0+data StripPrefix (prefix :: Symbol)++-- | Takes a type level string and removes that from the end of the text,+-- corresponds to 'Data.Text.stripSuffix.+--+-- @since 0.0.2.0+data StripSuffix (suffix :: Symbol)++-- | Takes a type level character known as the \"separator"\ and will break the+-- camel case string on its \"humps\" and then rejoin the string with the+-- separator.+--+-- @since 0.0.2.0+data CamelTo (separator :: Char)++-- | Specialized version of `CamelTo` where the separator is \"_\". Results in+-- snake cased strings.+--+-- @since 0.0.2.0+type CamelToSnake = CamelTo '_'++-- | Specialized version of `CamelTo` where the separator is \"-\". Results in+-- kebab cased strings.+--+-- @since 0.0.2.0+type CamelToKebab = CamelTo '-'++-- | This typeclass turns a type level \"tag\" into a function from @Text ->+-- Text@. In addition to the instances for the \"tags\", there are also+-- instances for type level lists and tuples up to an arity of 4.+--+-- __important__: For type level lists and tuples the modifiers are applied in+-- order from left to right.+--+-- >>> getKeyModifier @'[ToUpper, ToLower] "Hello World"+-- "hello world"+--+-- >>> getKeyModifier @(ToLower, ToUpper) "Hello World"+-- "HELLO WORLD"+--+-- >>> getKeyModifier @CamelToSnake "iLoveCFGProject"+-- "i_love_cfg_project"+--+-- @since 0.0.2.0+class KeyModifier t where+  getKeyModifier :: Text -> Text++instance (KeyModifier k) => KeyModifier ('TypeName k) where+  getKeyModifier = getKeyModifier @k++instance (KeyModifier k) => KeyModifier ('ConstructorName k) where+  getKeyModifier = getKeyModifier @k++instance KeyModifier Identity where+  getKeyModifier = id++instance KeyModifier '() where+  getKeyModifier = id++instance KeyModifier '[] where+  getKeyModifier = id++instance (KeyModifier a, KeyModifier as) => KeyModifier (a ': as) where+  getKeyModifier = getKeyModifier @as . getKeyModifier @a++instance (KeyModifier a, KeyModifier b) => KeyModifier (a, b) where+  getKeyModifier = getKeyModifier @b . getKeyModifier @a++instance (KeyModifier a, KeyModifier b, KeyModifier c) => KeyModifier (a, b, c) where+  getKeyModifier = getKeyModifier @c . getKeyModifier @b . getKeyModifier @a++instance (KeyModifier a, KeyModifier b, KeyModifier c, KeyModifier d) => KeyModifier (a, b, c, d) where+  getKeyModifier = getKeyModifier @d . getKeyModifier @c . getKeyModifier @b . getKeyModifier @a++instance KeyModifier ToLower where+  getKeyModifier = T.toLower++instance KeyModifier ToUpper where+  getKeyModifier = T.toUpper++instance KeyModifier LowerFirst where+  getKeyModifier t = fromMaybe t $ mapFirst toLower t++instance KeyModifier UpperFirst where+  getKeyModifier t = fromMaybe t $ mapFirst toUpper t++instance (KnownSymbol prefix) => KeyModifier (StripPrefix prefix) where+  getKeyModifier label =+    fromMaybe label . T.stripPrefix (T.pack . symbolVal $ Proxy @prefix) $ label++instance (KnownSymbol prefix) => KeyModifier (StripSuffix prefix) where+  getKeyModifier label =+    fromMaybe label . T.stripSuffix (T.pack . symbolVal $ Proxy @prefix) $ label++instance (KnownChar separator) => KeyModifier (CamelTo separator) where+  getKeyModifier = camelToText (charVal $ Proxy @separator)++-- | Map over the first character of a stream of 'Data.Text.Text'+--+-- @since 0.0.2.0+mapFirst :: (Char -> Char) -> Text -> Maybe Text+mapFirst f text = T.uncons text <&> \(first, rest) -> f first `T.cons` rest++-- | Function for breaking a camel case string on its \"humps\" and re-joining+-- on a provided separator char.+--+-- @since 0.0.2.0+camelTo+  :: Char+  -- ^ Separator character+  -> String+  -- ^ Camel cased string+  -> String+camelTo c = map toLower . go2 . go1+ where+  go1 "" = ""+  go1 (x : u : l : xs) | isUpper u && isLower l = x : c : u : l : go1 xs+  go1 (x : xs) = x : go1 xs+  go2 "" = ""+  go2 (l : u : xs) | isLower l && isUpper u = l : c : u : go2 xs+  go2 (x : xs) = x : go2 xs++-- | "Data.Text.Text" version of 'camelTo'+--+-- @since 0.0.2.0+camelToText :: Char -> Text -> Text+camelToText c = T.pack . camelTo c . T.unpack

@@ -1,22 +0,0 @@-module Cfg.Deriving.LabelModifier where--import Data.Text (Text)-import Data.Text qualified as T--data ToLower--data ToUpper--data Ident--class LabelModifier t where-    getLabelModifier :: Text -> Text--instance LabelModifier ToLower where-    getLabelModifier = T.toLower--instance LabelModifier ToUpper where-    getLabelModifier = T.toUpper--instance LabelModifier Ident where-    getLabelModifier = id

@@ -1,46 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Cfg.Deriving.SubConfig where--import Cfg.Deriving.LabelModifier (LabelModifier (..))-import Cfg.Options (ConfigOptions (..), defaultConfigOptions)-import Cfg.Source (NestedConfig (..))-import Cfg.Source.NestedConfig-import GHC.Generics (Generic (..))-import Cfg.Parser.ConfigParser-import Cfg.Parser-import Data.Coerce--newtype SubConfig a = SubConfig {unSubConfig :: a}--instance Generic a => Generic (SubConfig a) where-    type Rep (SubConfig a) = Rep a-    to = SubConfig . to-    from (SubConfig x) = from x--newtype SubConfigOpts t a = SubConfigOpts {unSubConfigOpts :: a}--instance Generic a => Generic (SubConfigOpts t a) where-    type Rep (SubConfigOpts t a) = Rep a-    to = SubConfigOpts . to-    from (SubConfigOpts x) = from x--class GetConfigOptions t where-    getConfigOptions :: ConfigOptions--instance (LabelModifier t) => GetConfigOptions t where-    getConfigOptions = ConfigOptions (getLabelModifier @t)---- Source-instance (Generic a, GConfigForest (Rep a)) => NestedConfig (SubConfig a) where-    toNestedConfig = defaultToNestedConfig @a defaultConfigOptions--instance (GetConfigOptions t, Generic a, GConfigForest (Rep a)) => NestedConfig (SubConfigOpts t a) where-    toNestedConfig = defaultToNestedConfig @a (getConfigOptions @t)---- Parser-instance (Generic a, GNestedParser (Rep a)) => NestedParser (SubConfig a) where-  parseNestedConfig tree = coerce `asTypeOf` fmap SubConfig $ defaultParseNestedConfig defaultConfigOptions tree--instance (GetConfigOptions t, Generic a, GNestedParser (Rep a)) => NestedParser (SubConfigOpts t a) where-  parseNestedConfig tree = coerce `asTypeOf` fmap SubConfigOpts $ defaultParseNestedConfig (getConfigOptions @t) tree

@@ -0,0 +1,40 @@+-- |+--  Module      : Cfg.Deriving.Value+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module provides a type 'Value' for generating instances for \"leaf\"+-- elements of your configuration tree. These are the elements you actually+-- care about and want to parse out of a configuration source.+module Cfg.Deriving.Value where++import Cfg.Parser+import Cfg.Parser.Value+import Data.Coerce+import GHC.Generics++-- | This newtype is used to derive 'ValueParser' instances for your types+-- using the deriving via mechanism. In general this should be used for sum+-- types, and product types without named fields (i.e. not records). The+-- majority of the types that you would want as values should have instances in+-- "Cfg.Source" and "Cfg.Parser".+--+-- @since 0.0.2.0+newtype Value a = Value {unValue :: a}++-- | @since 0.0.2.0+instance (Generic a) => Generic (Value a) where+  type Rep (Value a) = Rep a+  to = Value . to+  from (Value x) = from x++-- | @since 0.0.2.0+instance (Generic a, GValueParser (Rep a)) => ValueParser (Value a) where+  parser = coerce `asTypeOf` fmap Value $ defaultValueParser @a++-- | @since 0.0.2.0+instance (Generic a, GValueParser (Rep a)) => ConfigParser (Value a)

@@ -1,55 +1,154 @@-module Cfg.Env where+-- |+--  Module      : Cfg.Env+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module contains all the functions for interacting with environment+-- variables as a configuration source.+module Cfg.Env+  ( -- * Retrieval Functions+    envSourceSep+  , envSource+  , getEnvConfigSep+  , getEnvConfig +    -- * Printing Functions+  , printDotEnv'+  , printDotEnv+  )+where++import Cfg+import Cfg.Env.Keys+import Cfg.Parser+import Cfg.Source import Control.Monad.IO.Class (MonadIO, liftIO) import Data.List (intersperse)+import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO (writeFile)-import Data.Tree (Tree)+import KeyTree import System.Environment (lookupEnv)-import Tree.Append (mayAppendLeafA') import Prelude hiding (writeFile)-import Cfg.Parser-import Cfg.Source (RootConfig, toRootConfig)-import Cfg-import Cfg.Env.Keys --- | @since 0.0.1.0+-- | This function folds the tree from root to leaf accumulating the keys along+-- the way. At the leaf we lookup the aggregated key in the environment, if+-- there is a default then we use that for missing keys.+--+-- If you are looking at the source code this is what the functions in the+-- @where@ clause do:+--+--    - @valF@: Gets called on 'Pure' values in the original tree passed in,+--    these indicate defaulted values, so we use the default if looking the+--    value up in the environment failed.+--+--    - @accF@: This operates on the accumulated key, and is responsible for+--    looking up the value in the environment when we hit the @Free M.empty@+--    case.+--+--    - @stepF@: This is the step function for the fold and accumulates the+--    keys as we traverse down the tree.+--+--    - @mkKey@: This function is the same as 'Cfg.Env.Keys.getEnvKey' except+--    that it uses @flip mappend@. The reason for this is that we insert keys+--    into the accumulator as we traverse down so they end up in reversed+--    order, then we @foldr@ over them so we just need to make sure that we are+--    placing the elements at the end of the list on the left hand side of the+--    aggregate key.+--+-- @since 0.0.1.0 envSourceSep   :: forall m-   . (MonadFail m, MonadIO m)+   . (MonadIO m)   => Text-  -> Tree Text-  -> m (Tree Text)-envSourceSep sep = mayAppendLeafA' getLeafFromEnv []+  -- ^ Separator+  -> KeyTree Text Text+  -- ^ Configuration source+  -> m (KeyTree Text Text)+  -- ^ Configuration tree with values filled in+envSourceSep sep = mayAppendTraverse valF accF stepF []  where-  getLeafFromEnv :: [Text] -> m (Maybe Text)-  getLeafFromEnv keys = do-    let-      key = foldr (flip mappend) "" $ intersperse sep keys+  valF :: [Text] -> Text -> m Text+  valF keys def = fromMaybe def <$> accF keys -    liftIO $ (fmap T.pack) <$> (lookupEnv $ T.unpack key)+  accF :: [Text] -> m (Maybe Text)+  accF = fmap (fmap T.pack) . liftIO . lookupEnv . T.unpack . mkKey --- | @since 0.0.1.0-envSource :: (MonadFail m, MonadIO m) => Tree Text -> m (Tree Text)+  stepF :: Text -> [Text] -> KeyForest Text Text -> [Text]+  stepF key acc _ = key : acc++  mkKey :: [Text] -> Text+  mkKey keys = foldr (flip mappend) "" $ intersperse sep keys++-- | This function is the same as 'envSourceSep' but with the separator specialized to \"_\".+--+-- >>> import System.Environment+-- >>> import Data.Map qualified as M+-- >>> setEnv "A_B" "Functor"+-- >>> setEnv "A_C" "Applicative"+-- >>> setEnv "A_D" "Monad"+-- >>> envSource $ Free $ M.fromList [("A", Free $ M.fromList [("B", Free M.empty), ("C", Free M.empty), ("D", Free M.empty)])]+-- Free (fromList [("A",Free (fromList [("B",Pure "Functor"),("C",Pure "Applicative"),("D",Pure "Monad")]))])+--+-- @since 0.0.1.0+envSource :: (MonadFail m, MonadIO m) => KeyTree Text Text -> m (KeyTree Text Text) envSource = envSourceSep "_" --- | @since 0.0.1.0-printDotEnv' :: FilePath -> Text -> Tree Text -> IO ()+-- | This function can be used to print a dotenv style file with all the+-- aggregate keys, none of the values will be filled in.+--+-- Useful for testing what your expected environment variables should look+-- like, and generating an env var file template.+--+-- @since 0.0.1.0+printDotEnv'+  :: FilePath+  -- ^ Destination filepath+  -> Text+  -- ^ Separator+  -> KeyTree Text Text+  -- ^ Source representation+  -> IO () printDotEnv' path sep = writeFile path . foldMap (\line -> "export " <> line <> "=\n") . showEnvKeys' sep --- | @since 0.0.1.0-getEnvConfigSep :: (MonadFail m, MonadIO m, RootConfig a, RootParser a) => Text -> m (Either ConfigParseError a)+-- | Requires a type annotation for your configuration type (with a+-- 'ConfigSource' and 'ConfigParser' instance), and a separator, and will go+-- out and fetch the values from environment variables then return your type+-- parsed from those values.+--+-- @getEnvConfigSep \@AppConfig "_"@+--+-- @since 0.0.1.0+getEnvConfigSep+  :: forall a m+   . (MonadFail m, MonadIO m, ConfigSource a, ConfigParser a)+  => Text+  -- ^ Separator+  -> m (Either ConfigParseError a) getEnvConfigSep sep = getConfig $ envSourceSep sep --- | @since 0.0.1.0-getEnvConfig :: (MonadFail m, MonadIO m, RootConfig a, RootParser a) => m (Either ConfigParseError a)+-- | The same as 'getEnvConfigSep' but with the separator hard coded to \"_\"+--+-- @since 0.0.1.0+getEnvConfig+  :: forall a m. (MonadFail m, MonadIO m, ConfigSource a, ConfigParser a) => m (Either ConfigParseError a) getEnvConfig = getConfig $ envSource --- | @since 0.0.1.0-printDotEnv :: forall a. (RootConfig a) => FilePath -> IO ()+-- | The same as 'printDotEnv'' but with the separator hard coded to \"_\" and+-- it uses a type application to generate the configuration source tree+-- representation.+--+-- @printDotEnv \@AppConfig ".env"@+--+-- @since 0.0.1.0+printDotEnv :: forall a. (ConfigSource a) => FilePath -> IO () printDotEnv path =   writeFile path     . foldMap (\line -> "export " <> line <> "=\n")     . showEnvKeys' "_"-    $ toRootConfig @a+    $ configSource @a

@@ -1,27 +1,113 @@+-- |+--  Module      : Cfg.Env.Keys+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module provides helper functions for manipulating the keys on our+-- internal tree representation of a configuration; 'Cfg.KeyTree.KeyTree'.+--+-- These helper functions are generally oriented towards using environment+-- variables as your configuration source. module Cfg.Env.Keys where -import Data.Text (Text)-import Data.Tree (Tree, foldTree)-import Cfg.Source (RootConfig (..))+import Cfg.Source (ConfigSource (..))+import Data.Foldable import Data.List (intersperse)+import Data.Map.Strict (empty)+import Data.Text (Text)+import KeyTree --- | @since 0.0.1.0-getEnvKey :: Text -> [Text] -> Text-getEnvKey sep = foldr mappend "" . intersperse sep+-- | This function takes a separator and a list of keys and joins them from the+-- end of the list to the beginning, interspersed with the provided separator.+--+-- >>> getEnvKey "_" ["A", "B", "C"]+-- "A_B_C"+--+-- @since 0.0.1.0+getEnvKey+  :: Text+  -- ^ Separator+  -> [Text]+  -- ^ List of keys+  -> Text+getEnvKey sep = fold . intersperse sep --- | @since 0.0.1.0-getKeys :: Tree Text -> [[Text]]-getKeys = foldTree f+-- | Folds a 'Cfg.KeyTree.KeyTree' from leaf to root, into distinct key paths.+-- This is necessary for the way that hierarchical structures are represented+-- in environment variables (i.e. \"KEYA_SUBKEYA\", \"KEYA_SUBKEYB\").+--+-- Here is a visual representation of how the keys would get folded+--+-- @+--       A+--      / \\+--     B   C+--+--  [ [ "A", "B" ]+--  , [ "A", "C" ]+--  ]+-- @+-- >>> import KeyTree+-- >>> import Data.Map qualified as M+-- >>> getKeys $ Free $ M.singleton "A" $ Free (M.fromList [("B", Free M.empty), ("C", Free M.empty)])+-- [["A","B"],["A","C"]]+--+-- @since 0.0.1.0+getKeys :: KeyTree Text Text -> [[Text]]+getKeys = foldKeyTree valF stepF []  where-  f :: Text -> [[[Text]]] -> [[Text]]-  f label [] = [[label]]-  f label xs = concat $ fmap (label :) <$> xs+  stepF :: Text -> Free (Map Text) Text -> [[Text]] -> [[Text]]+  stepF key (Pure _) acc = [key] : acc+  stepF key t@(Free m) acc =+    if m == empty+      then [key] : acc+      else fmap (key :) (getKeys t) <> acc --- | @since 0.0.1.0-showEnvKeys' :: Text -> Tree Text -> [Text]-showEnvKeys' sep tree = getEnvKey sep <$> getKeys tree+  valF :: Text -> [[Text]]+  valF _ = [] --- | @since 0.0.1.0-showEnvKeys :: forall a. (RootConfig a) => Text -> [Text]-showEnvKeys sep = getEnvKey sep <$> (getKeys $ toRootConfig @a)+-- | Gets all the keys from a configuration tree, and flattens the hierarchy so that+-- each key is prefixed with its path through the tree.+--+-- Accepts separator to individuate the key prefixes.+--+-- >>> import KeyTree+-- >>> import Data.Map qualified as M+-- >>> showEnvKeys' "-" $ Free $ M.singleton "A" $ Free (M.fromList [("B", Free M.empty), ("C", Free M.empty)])+-- ["A-B","A-C"]+--+-- @since 0.0.1.0+showEnvKeys'+  :: Text+  -- ^ Separator+  -> KeyTree Text Text+  -- ^ Configuration tree+  -> [Text]+showEnvKeys' sep tree = getEnvKey sep <$> getKeys tree +-- | Same as 'showEnvKeys'' but the 'KeyTree.KeyTree' is generated via a 'configSource'+--+-- >>> import GHC.Generics (Generic (..))+-- >>> import Cfg.Source (ConfigSource(..))+-- >>> import Cfg.Parser (ConfigParser(..))+-- >>> import Cfg.Deriving.Config (Config(..))+-- >>> import Cfg.Source.Default (DefaultSource(..))+-- >>> :{+-- data Sub = Sub { c :: Int, d :: Bool }+--   deriving (Generic, Show, DefaultSource)+--   deriving (ConfigSource, ConfigParser) via Config Sub+-- data TypeCon = DataCon { a :: Sub }+--   deriving (Generic, Show, DefaultSource)+--   deriving (ConfigSource, ConfigParser) via Config TypeCon+-- :}+--+-- >>> showEnvKeys @TypeCon "_"+-- ["a_c","a_d"]+--+-- @since 0.0.1.0+showEnvKeys :: forall a. (ConfigSource a) => Text -> [Text]+showEnvKeys sep = getEnvKey sep <$> (getKeys $ configSource @a)

@@ -1,17 +1,87 @@-module Cfg.Options where+-- |+--  Module      : Cfg.Options+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module contains the options types that we pass to our generic+-- functions. Mostly these are used for registering text transformations on+-- keys, but another interesting use case is choosing between the type+-- constructor and the data constructor for deriving a name for root keys.+module Cfg.Options+  ( -- * Option Types+    KeyOptions (..)+  , RootKey (..)+  , RootOptions (..)+  , ConfigOptions (..) +    -- * Helper Functions+  , defaultKeyOptions+  , defaultRootOptions+  , defaultConfigOptions+  , keyModifier+  )+where+ import Data.Text (Text) +-- | Options that pertain to record field accessors.+--+-- @since 0.0.1.0+data KeyOptions = KeyOptions+  { keyOptionsModifier :: Text -> Text+  }++-- | Default key options, does no transformation to record field accessors.+--+-- @since 0.0.2.0+defaultKeyOptions :: KeyOptions+defaultKeyOptions = KeyOptions id++-- | Type that represents a decision between using the type constructor name or+-- the data constructor name as the root key.+--+-- This type is polymorphic so that we can use it to contain a term level text+-- transformation for root keys, as well as be used at the type level+-- parameterized by a type that defines the key modifiers to use.+--+-- @since 0.0.2.0+data RootKey a = ConstructorName a | TypeName a++-- | Options for manipulating a root key+--+-- @since 0.0.2.0 data RootOptions = RootOptions-  { rootOptionsLabelModifier :: Text -> Text-  , rootOptionsFieldOptions :: ConfigOptions+  { rootOptionsRootKey :: RootKey (Text -> Text)+  , rootOptionsModifier :: Text -> Text   } +-- | Default root key option, uses the type constructor name for the root key+-- and applies no transformations to the root key or keys derived from record+-- fields.+--+-- @since 0.0.2.0 defaultRootOptions :: RootOptions-defaultRootOptions = RootOptions id (ConfigOptions id)+defaultRootOptions = RootOptions (TypeName id) id -data ConfigOptions = ConfigOptions-  {configOptionsLabelModifier :: Text -> Text}+-- | Represents all possible kinds of configuration options.+--+-- @since 0.0.2.0+data ConfigOptions = Root RootOptions | Key KeyOptions +-- | Defaults to regular 'KeyOptions' (not 'RootOptions')+--+-- @since 0.0.2.0 defaultConfigOptions :: ConfigOptions-defaultConfigOptions = ConfigOptions id+defaultConfigOptions = Key defaultKeyOptions++-- | Helper function that allows us to generically extract the record field+-- modifiers from either a 'RootOptions' or a 'KeyOptions' record.+--+-- @since 0.0.2.0+keyModifier :: ConfigOptions -> (Text -> Text)+keyModifier (Root options) = rootOptionsModifier options+keyModifier (Key options) = keyOptionsModifier options

@@ -1,143 +1,223 @@ {-# LANGUAGE DefaultSignatures #-} -module Cfg.Parser where+-- |+--  Module      : Cfg.Parser+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module contains the type classes for parsing a configuration type from+-- a source, as well as instances for most basic Haskell types. One important+-- interaction to note is that we use a default instance for 'ConfigParser'+-- that dispatches to a 'ValueParser' instances. This is how we distinguish+-- between a \"parser\" that just navigates the tree representation of our+-- configuration and a parser that actually converts from text to our Haskell+-- type.+module Cfg.Parser+  ( -- * Parser Typeclasses+    ConfigParser (..)+  , ValueParser (..) +    -- * Parser Types+  , Parser+  , ConfigParseError (..)+  )+where+ import Control.Error (note) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL-import Data.Functor (void, ($>))+import Data.Functor (void) import Data.Int import Data.List.NonEmpty (NonEmpty, fromList)+import Data.Map.Strict qualified as M import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy qualified as TL-import Data.Tree (Tree (..)) import Data.Void (Void) import Data.Word import GHC.Generics (Generic)-import Text.Megaparsec (Parsec, anySingle, between, empty, option, parseMaybe, sepBy, sepBy1, some, takeRest, try, (<|>))+import KeyTree+import Text.Megaparsec+  ( Parsec+  , anySingle+  , between+  , empty+  , option+  , parseMaybe+  , sepBy+  , sepBy1+  , some+  , takeRest+  , try+  , (<|>)+  ) import Text.Megaparsec.Char (char, digitChar, space1, string, string') import Text.Megaparsec.Char.Lexer qualified as L +-- | Type alias for our megaparsec parser+--+-- @since 0.0.1.0 type Parser = Parsec Void Text +-- | Type errors we can encounter when parsing+--+-- @since 0.0.2.0 data ConfigParseError-  = UnmatchedFields [Tree Text]-  | MismatchedRootKey Text Text-  | MismatchedKeyAndField Text (Text, Text)-  | MissingKeys [Text]-  | MissingValue Text-  | UnexpectedKeys Text [Tree Text]-  | ValueParseError Text+  = -- | We encountered a 'Data.Map.Map' that was missing a key.+    MissingKey+      Text+      -- ^ The record field name that was missing.+      (KeyTree Text Text)+      -- ^ The subtree that was missing an entry.+  | -- | Expected to find a subtree aka a 'Free' with a map in it, but instead+    -- we found a 'Pure'.+    ExpectedKeyFoundValue+      Text+      -- ^ The key that was missing+      Text+      -- ^ The value that was found+  | -- | Expected to find a 'Pure' with a value but instead found a subtree+    ExpectedValueFoundForest+      (KeyTree Text Text)+      -- ^ The subtree that was found instead+  | -- | Ran a 'parser' and was unable to parse value+    ValueParseError+      Text+      -- ^ The parser error   deriving (Eq, Show, Generic) -class RootParser a where-  parseRootConfig :: Tree Text -> Either ConfigParseError a+-- | This is the instance that allows us to parse a result from our+-- configuration source after we have retrieved it.+--+-- @since 0.0.2.0+class ConfigParser a where+  -- | Takes in the tree representation of our configuration and parses out our Haskell type+  --+  --  The default instance allows us to wrap a 'ValueParser' in a+  --  'ConfigParser', this allows us to use a uniform typeclass for parsing,+  --  but at the same time distinguish between traversing the key structure and+  --  actually parsing the textual value.+  parseConfig :: KeyTree Text Text -> Either ConfigParseError a+  default parseConfig :: (ValueParser a) => KeyTree Text Text -> Either ConfigParseError a+  parseConfig (Pure val) = note (ValueParseError val) $ parseMaybe parser val+  parseConfig kt = Left $ ExpectedValueFoundForest kt -class NestedParser a where-  parseNestedConfig :: Tree Text -> Either ConfigParseError a-  default parseNestedConfig :: (ValueParser a) => Tree Text -> Either ConfigParseError a-  parseNestedConfig (Node val []) = note (ValueParseError val) $ parseMaybe parser val-  parseNestedConfig (Node label xs) = Left $ UnexpectedKeys label xs+-- | This is a text parser that we use to parse the eventual values we get from a+-- configuration.+--+-- @since 0.0.2.0+class ValueParser a where+  parser :: Parser a +-- | Lexer parser helper.+--+-- @since 0.0.2.0 sp :: Parsec Void Text () sp = L.space space1 empty empty -class ValueParser a where-  parser :: Parser a- -- | @since 0.0.1.0 instance ValueParser () where   parser = string "()" >> pure ()  -- | @since 0.0.1.0-instance NestedParser ()+instance ConfigParser ()  -- | @since 0.0.1.0 instance ValueParser Bool where   parser = try (string' "true" >> pure True) <|> (string' "false" >> pure False)  -- | @since 0.0.1.0-instance NestedParser Bool+instance ConfigParser Bool  -- | @since 0.0.1.0 instance ValueParser Char where   parser = anySingle  -- | @since 0.0.1.0-instance NestedParser Char+instance ConfigParser Char  -- | @since 0.0.1.0 instance ValueParser TL.Text where   parser = TL.fromStrict <$> takeRest  -- | @since 0.0.1.0-instance NestedParser TL.Text+instance ConfigParser TL.Text  -- | @since 0.0.1.0 instance ValueParser BL.ByteString where   parser = BL.fromStrict . encodeUtf8 <$> takeRest  -- | @since 0.0.1.0-instance NestedParser BL.ByteString+instance ConfigParser BL.ByteString  -- | @since 0.0.1.0 instance ValueParser BS.ByteString where   parser = encodeUtf8 <$> takeRest  -- | @since 0.0.1.0-instance NestedParser BS.ByteString+instance ConfigParser BS.ByteString --- @since 0.0.1.0+-- | @since 0.0.1.0 instance ValueParser Text where   parser = takeRest  -- | @since 0.0.1.0-instance NestedParser Text+instance ConfigParser Text  -- | @since 0.0.1.0-instance ValueParser a => ValueParser [a] where+instance (ValueParser a) => ValueParser [a] where   parser = between (L.symbol sp "[") (L.symbol sp "]") $ parser @a `sepBy` (L.symbol sp ",")  -- | @since 0.0.1.0-instance ValueParser a => NestedParser [a]+instance (ValueParser a) => ConfigParser [a]  -- | @since 0.0.1.0-instance ValueParser a => ValueParser (NonEmpty a) where+instance (ValueParser a) => ValueParser (NonEmpty a) where   parser = between (L.symbol sp "[") (L.symbol sp "]") $ fromList <$> parser @a `sepBy1` (L.symbol sp ",")  -- | @since 0.0.1.0-instance ValueParser a => NestedParser (NonEmpty a)+instance (ValueParser a) => ConfigParser (NonEmpty a)  -- | @since 0.0.1.0-instance ValueParser a => ValueParser (Maybe a) where-  parser =-    (try (string "Nothing") $> Nothing)-      <|> (L.symbol sp "Just" >> (Just <$> parser @a))--instance ValueParser a => NestedParser (Maybe a)+instance (ValueParser a) => ConfigParser (Maybe a) where+  parseConfig (Free m) =+    if m == M.empty+      then Right Nothing+      else Left $ ExpectedValueFoundForest (Free m)+  parseConfig (Pure v) = Just <$> note (ValueParseError v) (parseMaybe (parser @a) v) --- Numeric Types+-- Numeric parser helpers -rd :: Read a => Text -> a+-- | @since 0.0.2.0+rd :: (Read a) => Text -> a rd = read . T.unpack +-- | @since 0.0.2.0 plus :: Parser Text plus = char '+' >> number +-- | @since 0.0.2.0 minus :: Parser Text minus = liftA2 (T.cons) (char '-') number +-- | @since 0.0.2.0 number :: Parser Text number = T.pack <$> some digitChar +-- | @since 0.0.2.0 decimal :: Parser Text decimal = option "" $ (T.cons) <$> char '.' <*> number +-- | @since 0.0.2.0 integral :: (Read a) => Parser a integral = rd <$> (try plus <|> try minus <|> number) +-- | @since 0.0.2.0 fractional :: (Read a) => Parser a fractional = fmap rd $ liftA2 (<>) integral decimal @@ -145,79 +225,92 @@ instance ValueParser Double where   parser = fractional -instance NestedParser Double+-- | @since 0.0.1.0+instance ConfigParser Double  -- | @since 0.0.1.0 instance ValueParser Float where   parser = fractional -instance NestedParser Float+-- | @since 0.0.1.0+instance ConfigParser Float --- @since 0.0.1.0+-- | @since 0.0.1.0 instance ValueParser Int where   parser = integral -instance NestedParser Int+-- | @since 0.0.1.0+instance ConfigParser Int  -- | @since 0.0.1.0 instance ValueParser Int8 where   parser = integral -instance NestedParser Int8+-- | @since 0.0.1.0+instance ConfigParser Int8  -- | @since 0.0.1.0 instance ValueParser Int16 where   parser = integral -instance NestedParser Int16+-- | @since 0.0.1.0+instance ConfigParser Int16  -- | @since 0.0.1.0 instance ValueParser Int32 where   parser = integral -instance NestedParser Int32+-- | @since 0.0.1.0+instance ConfigParser Int32  -- | @since 0.0.1.0 instance ValueParser Int64 where   parser = integral -instance NestedParser Int64+-- | @since 0.0.1.0+instance ConfigParser Int64  -- | @since 0.0.1.0 instance ValueParser Integer where   parser = integral -instance NestedParser Integer+-- | @since 0.0.1.0+instance ConfigParser Integer  -- | @since 0.0.1.0 instance ValueParser Word where   parser = rd <$> number -instance NestedParser Word+-- | @since 0.0.1.0+instance ConfigParser Word  -- | @since 0.0.1.0 instance ValueParser Word8 where   parser = rd <$> number -instance NestedParser Word8+-- | @since 0.0.1.0+instance ConfigParser Word8  -- | @since 0.0.1.0 instance ValueParser Word16 where   parser = rd <$> number -instance NestedParser Word16+-- | @since 0.0.1.0+instance ConfigParser Word16  -- | @since 0.0.1.0 instance ValueParser Word32 where   parser = rd <$> number -instance NestedParser Word32+-- | @since 0.0.1.0+instance ConfigParser Word32  -- | @since 0.0.1.0 instance ValueParser Word64 where   parser = rd <$> number -instance NestedParser Word64+-- | @since 0.0.1.0+instance ConfigParser Word64  -- | @since 0.0.1.0 instance (ValueParser a, ValueParser b) => ValueParser (a, b) where@@ -228,4 +321,4 @@     pure (a, b)  -- | @since 0.0.1.0-instance (ValueParser a, ValueParser b) => NestedParser (a, b)+instance (ValueParser a, ValueParser b) => ConfigParser (a, b)

@@ -0,0 +1,135 @@+-- |+--  Module      : Cfg.Parser.Config+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module contains the generic machinery for building parsers from the+-- structure of a type. The majority of the work here is threading a+-- 'Cfg.Parser.Value.ValueParser' through the 'KeyTree.KeyTree' structure until+-- a 'Pure' value is hit, and then dispatching the correct parser.+module Cfg.Parser.Config+  ( -- * Default Parser Function+    defaultParseConfig++    -- * Generic Machinery+  , GConfigParser (..)+  )+where++import Cfg.Options+import Cfg.Parser (ConfigParseError (..), ConfigParser (..))+import Data.Kind (Type)+import Data.Map qualified as M+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics+import KeyTree++-- | This function is the workhorse of the generic machinery, however the user+-- should never have to invoke it directly. Instead, one of the newtypes from+-- 'Cfg.Deriving.Config' should call into this function in the definition of a+-- 'Cfg.Parser.ConfigParser' instance. The deriving via type should pull out+-- the 'ConfigOptions' from type level information.+--+-- @since 0.0.1.0+defaultParseConfig+  :: forall a+   . (Generic a, GConfigParser (Rep a))+  => ConfigOptions+  -> KeyTree Text Text+  -> Either ConfigParseError a+defaultParseConfig opts tree = fmap 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.+--+-- @since 0.0.2.0+class GConfigParser (f :: Type -> Type) where+  gParseConfig :: ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)++-- | This is the \"base case\", since "GHC.Generics" don't recurse the generic+-- represetation multiple levels, @a@ is just a plain type. Therefore we call+-- 'parseConfig' on it. @a@ may be another nested record, in which case+-- 'gParseConfig' will probably get called again, but for the generic+-- representation of a sub-tree. Or it will find the default instance for+-- 'ConfigParser' (indicating that we have reached a leaf) and dispatch to a+-- value parser through 'parseConfig'.+--+-- @since 0.0.2.0+instance (ConfigParser a) => GConfigParser (K1 R a) where+  gParseConfig _ kt = K1 <$> parseConfig kt++-- | This is the type constructor case, if we are dealing with a+-- 'Cfg.Deriving.Config.ConfigRoot' instance, then we have lookup the \"root+-- key\", but in all other cases we just keep recursing.+--+-- @since 0.0.2.0+instance (GConfigParser f, Datatype d) => GConfigParser (M1 D d f) where+  gParseConfig opts t@(Free keyForest) =+    case opts of+      Root (RootOptions{rootOptionsRootKey = TypeName modifier}) ->+        let+          key = modifier . T.pack $ datatypeName @d undefined+        in+          case M.lookup key keyForest of+            Just subTree -> M1 <$> gParseConfig opts subTree+            Nothing -> Left $ MissingKey key t+      _ -> M1 <$> gParseConfig opts t+  gParseConfig opts (Pure value) = Left $ ExpectedKeyFoundValue key value+   where+    key = keyModifier opts . T.pack $ datatypeName @d undefined++-- | This is the data constructor case, if we are dealing with a+-- 'Cfg.Deriving.Config.ConfigRoot' instance, then we have lookup the \"root+-- key\", but in all other cases we just keep recursing.+--+-- @since 0.0.2.0+instance (Constructor c, GConfigParser f) => GConfigParser (M1 C c f) where+  gParseConfig opts t@(Free keyForest) =+    case opts of+      Root (RootOptions{rootOptionsRootKey = ConstructorName modifier}) ->+        let+          key = modifier . T.pack $ conName @c undefined+        in+          case M.lookup key keyForest of+            Just subTree -> M1 <$> gParseConfig opts subTree+            Nothing -> Left $ MissingKey key t+      _ -> M1 <$> gParseConfig opts t+  gParseConfig opts (Pure value) = Left $ ExpectedKeyFoundValue key value+   where+    key = keyModifier opts . T.pack $ conName @c undefined++-- | This is the most important case, we need to look up the subconfig by key+-- (just the record field with all key modifiers applied), and then recursively+-- parse the sub tree.+--+-- @since 0.0.2.0+instance (Selector s, GConfigParser f) => GConfigParser (M1 S s f) where+  gParseConfig opts (Pure value) = Left $ ExpectedKeyFoundValue key value+   where+    key = keyModifier opts . T.pack $ selName @s undefined+  gParseConfig opts t@(Free keyForest) =+    case M.lookup selectorName keyForest of+      Nothing -> Left $ MissingKey selectorName t+      Just subTree -> M1 <$> gParseConfig opts subTree+   where+    selectorName = keyModifier opts . T.pack $ selName @s undefined++-- | This is the product case, we just distribute the parsers over the+-- different product fields.+--+-- Notably, there is no sum type case. We could potentially add that in the future,+-- allowing users to specify different cases of configuration. But right now+-- that seems like it would be more confusing than helpful, so we just give a+-- type error by eliding the instance.+--+-- @since 0.0.2.0+instance (GConfigParser a, GConfigParser b) => GConfigParser (a :*: b) where+  gParseConfig opts xs = do+    a <- gParseConfig opts xs+    b <- gParseConfig opts xs+    pure $ a :*: b

@@ -1,94 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-module Cfg.Parser.ConfigParser where--import Cfg.Options (ConfigOptions (..), RootOptions (..))-import Cfg.Parser (ConfigParseError (..), NestedParser (..))-import Data.Kind (Type)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Tree (Tree (..))-import GHC.Generics-import Data.List--defaultParseRootConfig ::-    forall a.-    (Generic a, GRootConfigParser (Rep a)) =>-    RootOptions ->-    Tree Text ->-    Either ConfigParseError a-defaultParseRootConfig opts tree = fmap to $ gParseRootConfig opts tree--class GRootConfigParser (f :: Type -> Type) where-    gParseRootConfig :: RootOptions -> Tree Text -> Either ConfigParseError (f p)--instance GRootConfigParser f => GRootConfigParser (M1 D s f) where-    gParseRootConfig opts tree = M1 <$> gParseRootConfig opts tree--instance (Selector s, GNestedParser f) => GRootConfigParser (M1 S s f) where-    gParseRootConfig opts tree = M1 <$> gParseNestedConfig (rootOptionsFieldOptions opts) tree--instance (Constructor c, GRootConfigParser f) => GRootConfigParser (M1 C c f) where-    gParseRootConfig opts t@(Node label _) =-        if label == (rootOptionsLabelModifier opts . T.pack $ conName m)-            then M1 <$> gParseRootConfig opts t-            else Left $ MismatchedRootKey label (rootOptionsLabelModifier opts . T.pack $ conName m)-      where-        m :: t c f a-        m = undefined--instance (GFieldParser (a :*: b)) => GRootConfigParser (a :*: b) where-    gParseRootConfig opts (Node _ forest) = gParseFields (rootOptionsFieldOptions opts) forest--class FieldParser a where-    parseFields :: [Tree Text] -> Either ConfigParseError a--class GFieldParser (f :: Type -> Type) where-    gParseFields :: ConfigOptions -> [Tree Text] -> Either ConfigParseError (f p)--instance (Selector s, GNestedParser f) => GFieldParser (M1 S s f) where-    gParseFields opts xs = case find ((==) (configOptionsLabelModifier opts . T.pack $ selName @s undefined) . rootLabel) xs of-                              Nothing -> Left $ MissingKeys [configOptionsLabelModifier opts . T.pack $ selName @s undefined]-                              Just t -> M1 <$> gParseNestedConfig opts t--instance (GFieldParser a, GFieldParser b) => GFieldParser (a :*: b) where-    gParseFields opts xs = do-        a <- gParseFields opts xs-        b <- gParseFields opts xs-        pure $ a :*: b--defaultParseNestedConfig ::-    forall a.-    (Generic a, GNestedParser (Rep a)) =>-    ConfigOptions ->-    Tree Text ->-    Either ConfigParseError a-defaultParseNestedConfig opts tree = fmap to $ gParseNestedConfig opts tree--class GNestedParser (f :: Type -> Type) where-    gParseNestedConfig :: ConfigOptions -> Tree Text -> Either ConfigParseError (f p)--instance NestedParser a => GNestedParser (K1 R a) where-    gParseNestedConfig _ (Node label []) = Left $ MissingValue label-    gParseNestedConfig _ (Node _ [val]) = K1 <$> parseNestedConfig val-    gParseNestedConfig _ tree = K1 <$> parseNestedConfig tree--instance (GNestedParser f) => GNestedParser (M1 D c f) where-    gParseNestedConfig opts t = M1 <$> gParseNestedConfig opts t--instance (Constructor c, GNestedParser f) => GNestedParser (M1 C c f) where-    gParseNestedConfig opts t = M1 <$> gParseNestedConfig opts t--instance (Selector s, GNestedParser f) => GNestedParser (M1 S s f) where-    gParseNestedConfig opts t@(Node label _) =-        if label == modifiedSelectorName-            then Left $ MismatchedKeyAndField label (T.pack $ selName m, modifiedSelectorName)-            else M1 <$> gParseNestedConfig opts t-      where-        m :: t s f a-        m = undefined--        modifiedSelectorName :: Text-        modifiedSelectorName = configOptionsLabelModifier opts . T.pack $ selName m--instance (GFieldParser (a :*: b)) => GNestedParser (a :*: b) where-    gParseNestedConfig opts (Node _ forest) = gParseFields opts forest

@@ -0,0 +1,74 @@+-- |+--  Module      : Cfg.Parser.Value+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module contains the generic machinery for value parsers. The main use+-- case for deriving 'Cfg.Parser.ValueParser' generically is for sum types, as+-- instances for most common types are provided in "Cfg.Parser".+module Cfg.Parser.Value where++import Cfg.Parser+import Data.Kind (Type)+import Data.Text qualified as T+import GHC.Generics+import Text.Megaparsec+import Text.Megaparsec.Char (string)++-- | This is the function that hooks into the generic machinery. It is called+-- by the deriving mechanism in "Cfg.Deriving.Value".+--+-- @since 0.0.2.0+defaultValueParser+  :: forall a+   . (Generic a, GValueParser (Rep a))+  => Parser a+defaultValueParser = fmap to $ gParser @(Rep a)++-- | This is a generic version of 'Cfg.Parser.ValueParser'+--+-- @since 0.0.2.0+class GValueParser (f :: Type -> Type) where+  gParser :: Parser (f p)++-- | @since 0.0.2.0+instance GValueParser V1 where+  gParser = undefined++-- | @since 0.0.2.0+instance GValueParser U1 where+  gParser = string "()" >> pure U1++-- | @since 0.0.2.0+instance (ValueParser a) => GValueParser (K1 R a) where+  gParser = K1 <$> parser @a++-- | @since 0.0.2.0+instance (GValueParser f) => GValueParser (M1 D s f) where+  gParser = M1 <$> gParser @f++-- | @since 0.0.2.0+instance (Constructor c) => GValueParser (M1 C c U1) where+  gParser = M1 U1 <$ string (T.pack $ conName @c undefined)++-- | @since 0.0.2.0+instance (GValueParser f) => GValueParser (M1 S s f) where+  gParser = M1 <$> gParser @f++-- | This is the main instance, which distributs a value parser over a sum type+-- using retry and alternative.+--+-- @since 0.0.2.0+instance (GValueParser a, GValueParser b) => GValueParser (a :+: b) where+  gParser = L1 <$> (try $ gParser @a) <|> R1 <$> (gParser @b)++-- | This is also an important instance for product types with unnamed fields+-- that are intended to be parsed as values (not nested configurations).+--+-- @since 0.0.2.0+instance (GValueParser a, GValueParser b) => GValueParser (a :*: b) where+  gParser = liftA2 (:*:) (gParser @a) (gParser @b)

@@ -1,41 +0,0 @@-module Cfg.Parser.ValueParser where--import Cfg.Parser-import GHC.Generics-import Data.Kind (Type)-import Text.Megaparsec-import Text.Megaparsec.Char (string)-import qualified Data.Text as T--defaultValueParser ::-    forall a.-    (Generic a, GValueParser (Rep a)) =>-    Parser a-defaultValueParser = fmap to $ gParser @(Rep a)--class GValueParser (f :: Type -> Type) where-    gParser :: Parser (f p)--instance GValueParser V1 where-    gParser = undefined--instance GValueParser U1 where-    gParser = string "()" >> pure U1--instance ValueParser a => GValueParser (K1 R a) where-    gParser = K1 <$> parser @a--instance GValueParser f => GValueParser (M1 D s f) where-    gParser = M1 <$> gParser @f--instance (Constructor c) => GValueParser (M1 C c U1) where-    gParser = M1 U1 <$ string (T.pack $ conName @c undefined)  --instance (GValueParser f) => GValueParser (M1 S s f) where-    gParser = M1 <$> gParser @f--instance (GValueParser a, GValueParser b) => GValueParser (a :*: b) where-    gParser = liftA2 (:*:) (gParser @a) (gParser @b)--instance (GValueParser a, GValueParser b) => GValueParser (a :+: b) where-    gParser = L1 <$> (try $ gParser @a) <|> R1 <$> (gParser @b)

@@ -1,102 +1,128 @@-module Cfg.Source where+-- |+--  Module      : Cfg.Source+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module contains the type classes for generating a 'KeyTree.KeyTree'+-- representation of a configuration source. The primary purpose is to generate+-- a \"serialized\" version of our Haskell type that can be easily mapped to+-- configuration sources.+module Cfg.Source+  ( FetchSource+  , ConfigSource (..)+  )+where -import Cfg.Deriving.ConfigValue (ConfigValue)+import Cfg.Deriving.Value (Value) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL-import Data.Int-import Data.List.NonEmpty+import Data.Int (Int16, Int32, Int64, Int8)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (empty) import Data.Text (Text) import Data.Text.Lazy qualified as TL-import Data.Tree (Tree)-import Data.Vector-import Data.Word---- | @since 0.0.1.0-type FetchSource m = Tree Text -> m (Tree Text)+import Data.Vector (Vector)+import Data.Word (Word16, Word32, Word64, Word8)+import KeyTree (Free (..), KeyTree) --- | @since 0.0.1.0-class RootConfig a where-  toRootConfig :: Tree Text+-- | This type alias represents a function that fetches values from an external+-- configuration source and inserts them into the leaves of our+-- 'KeyTree.KeyTree'+--+-- @since 0.0.1.0+type FetchSource m = KeyTree Text Text -> m (KeyTree Text Text) --- | @since 0.0.1.0-class NestedConfig a where-  toNestedConfig :: [Tree Text]+-- | This is the instance that allows us to construct a tree representation of+-- type @a@ based on its structure.+--+-- @since 0.0.1.0+class ConfigSource a where+  -- | Since the structure of @a@ is statically known this 'KeyTree.KeyTree'+  -- can be thought of as a constant, no runtime computation required!+  configSource :: KeyTree Text Text --- | @since 0.0.1.0-instance NestedConfig (ConfigValue a) where-  toNestedConfig = []+-- | Base case for 'ConfigSource', inserts an empty map that indicates we are+-- \"expecting a value here\"+--+-- @since 0.0.1.0+instance ConfigSource (Value a) where+  configSource = Free empty  -- | @since 0.0.1.0-deriving via (ConfigValue ()) instance NestedConfig ()+deriving via (Value ()) instance ConfigSource () --- | @since 0.0.1.0-deriving via (ConfigValue Bool) instance NestedConfig Bool+-- | @since 0.0.1.1+deriving via (Value Bool) instance ConfigSource Bool  -- | @since 0.0.1.0-deriving via (ConfigValue Char) instance NestedConfig Char+deriving via (Value Char) instance ConfigSource Char  -- | @since 0.0.1.0-deriving via (ConfigValue TL.Text) instance NestedConfig TL.Text+deriving via (Value TL.Text) instance ConfigSource TL.Text  -- | @since 0.0.1.0-deriving via (ConfigValue BL.ByteString) instance NestedConfig BL.ByteString+deriving via (Value BL.ByteString) instance ConfigSource BL.ByteString  -- | @since 0.0.1.0-deriving via (ConfigValue BS.ByteString) instance NestedConfig BS.ByteString+deriving via (Value BS.ByteString) instance ConfigSource BS.ByteString  -- | @since 0.0.1.0-deriving via (ConfigValue Text) instance NestedConfig Text+deriving via (Value Text) instance ConfigSource Text  -- | @since 0.0.1.0-deriving via (ConfigValue [a]) instance NestedConfig [a]+deriving via (Value [a]) instance ConfigSource [a]  -- | @since 0.0.1.0-deriving via (ConfigValue (NonEmpty a)) instance NestedConfig (NonEmpty a)+deriving via (Value (NonEmpty a)) instance ConfigSource (NonEmpty a)  -- | @since 0.0.1.0-deriving via (ConfigValue (Vector a)) instance NestedConfig (Vector a)+deriving via (Value (Vector a)) instance ConfigSource (Vector a)  -- | @since 0.0.1.0-deriving via (ConfigValue (Maybe a)) instance NestedConfig (Maybe a)+deriving via (Value (Maybe a)) instance ConfigSource (Maybe a)  -- | @since 0.0.1.0-deriving via (ConfigValue Double) instance NestedConfig Double+deriving via (Value Double) instance ConfigSource Double  -- | @since 0.0.1.0-deriving via (ConfigValue Float) instance NestedConfig Float+deriving via (Value Float) instance ConfigSource Float  -- | @since 0.0.1.0-deriving via (ConfigValue Int) instance NestedConfig Int+deriving via (Value Int) instance ConfigSource Int  -- | @since 0.0.1.0-deriving via (ConfigValue Int8) instance NestedConfig Int8+deriving via (Value Int8) instance ConfigSource Int8  -- | @since 0.0.1.0-deriving via (ConfigValue Int16) instance NestedConfig Int16+deriving via (Value Int16) instance ConfigSource Int16  -- | @since 0.0.1.0-deriving via (ConfigValue Int32) instance NestedConfig Int32+deriving via (Value Int32) instance ConfigSource Int32  -- | @since 0.0.1.0-deriving via (ConfigValue Int64) instance NestedConfig Int64+deriving via (Value Int64) instance ConfigSource Int64  -- | @since 0.0.1.0-deriving via (ConfigValue Integer) instance NestedConfig Integer+deriving via (Value Integer) instance ConfigSource Integer  -- | @since 0.0.1.0-deriving via (ConfigValue Word) instance NestedConfig Word+deriving via (Value Word) instance ConfigSource Word  -- | @since 0.0.1.0-deriving via (ConfigValue Word8) instance NestedConfig Word8+deriving via (Value Word8) instance ConfigSource Word8  -- | @since 0.0.1.0-deriving via (ConfigValue Word16) instance NestedConfig Word16+deriving via (Value Word16) instance ConfigSource Word16  -- | @since 0.0.1.0-deriving via (ConfigValue Word32) instance NestedConfig Word32+deriving via (Value Word32) instance ConfigSource Word32  -- | @since 0.0.1.0-deriving via (ConfigValue Word64) instance NestedConfig Word64+deriving via (Value Word64) instance ConfigSource Word64  -- | @since 0.0.1.0-deriving via (ConfigValue (a, b)) instance NestedConfig (a, b)+deriving via (Value (a, b)) instance ConfigSource (a, b)

@@ -0,0 +1,161 @@+-- |+--  Module      : Cfg.Source.Config+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module contains the generic machinery for generating a tree+-- representation of your configuration, this tree representation is intended+-- to be used with various sources. The tree structure should match the+-- structure of your (potentially) nested record type.+--+-- It is important to note that defaults are injected here, and not in the+-- parser stage. We use a 'DefaultSource' instance to inject 'Pure' values at+-- the leaves that can be used if the source fetcher doesn't return a value for+-- that key. In the case that there is no default a 'Free Data.Map.empty' is+-- placed to represent a required value.+module Cfg.Source.Config+  ( -- * Default Source Generator+    defaultConfigSource++    -- * Generic Machinery+  , GConfigSource (..)+  )+where++import Cfg.Options+import Cfg.Source+import Cfg.Source.Default+import Data.Kind (Type)+import Data.Map.Strict (empty, singleton)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics+import KeyTree++-- | This function is used by the deriving via machinery to dispatch to the+-- generic machinery, the user should never have to invoke it directly. This+-- takes in a 'ConfigOptions' which are retrieved from the deriving via+-- newtypes, and also threads a 'DefaultSource' instance through so that we can+-- dispatch to 'defaults' in the 'K1' case.+--+-- @since 0.0.2.0+defaultConfigSource+  :: forall a. (DefaultSource a, Generic a, GConfigSource (Rep a)) => ConfigOptions -> KeyTree Text Text+defaultConfigSource opts = gConfigSource @(Rep a) (defaults @a) opts++-- | This class is the generic version of 'ConfigSource. It recurses on the+-- generic structure of a type, building up 'KeyTree' representation.+--+-- @since 0.0.2.0+class GConfigSource (a :: Type -> Type) where+  gConfigSource :: (Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text++-- | This is the \"base case\", since "GHC.Generics" don't recurse the generic+-- represetation multiple levels, @a@ is just a plain type. Therefore we call+-- 'configSource' on it. @a@ may be another nested record, in which case+-- 'Cfg.Parser.Config.gParseConfig' will probably get called again, but for the+-- generic representation of a sub-tree. It will do this until it finds a+-- 'ConfigSource' instance for 'Cfg.Deriving.Value.Value' which will just add a+-- 'Free Data.Map.empty' (indicating a hole to be filled when we fetch the+-- configuration).+--+-- @since 0.0.2.0+instance (ConfigSource a) => GConfigSource (K1 R a) where+  gConfigSource _ _ = configSource @a++-- | This instance is important because it does the work of pulling off the+-- field selector name, and creating a sub-tree under that key by calling+-- 'gConfigSource' recursively. If there is a default for that selector then no+-- sub-tree is created, instead we insert a \"placeholder\" value tagged by+-- 'Pure' to represent that it is the end of the tree.+--+-- We detect if a default exists by calling 'defaults' from the 'DefaultSource'+-- instance on the selector, @defaults@ is of type @Text -> Maybe Text@, so the+-- @Nothing@ case indicates no default.+--+-- @since 0.0.2.0+instance (Selector s, GConfigSource f) => GConfigSource (M1 S s f) where+  gConfigSource def opts =+    if selName @s undefined == ""+      then -- TODO: Would be nice if we could turn this into a compile time error.+        error "Can only create a tree for named product types i.e. Records with named fields"+      else case def selectorName of+        Nothing -> Free $ singleton key value+        Just val -> Free $ singleton key (Pure val)+   where+    selectorName :: Text+    selectorName = T.pack $ selName @s undefined++    key :: Text+    key = keyModifier opts $ selectorName++    value :: KeyTree Text Text+    value = gConfigSource @f def opts++-- | This is the data constructor case, if we are dealing with a+-- 'Cfg.Deriving.Config.ConfigRoot' instance, then we have to create an extra layer with the \"root+-- key\" as a key and then a subtree (calculated by recursively calling 'gConfigSource') as the value.+--+-- @since 0.0.2.0+instance (Constructor c, GConfigSource f) => GConfigSource (M1 C c f) where+  gConfigSource def opts =+    case opts of+      Root (RootOptions{rootOptionsRootKey = ConstructorName modifier}) ->+        if conIsRecord @c undefined+          then Free $ singleton (modifier key) (gConfigSource @f def opts)+          else -- TODO: Would be nice if we could turn this into a compile time error.+            error "Can only create a tree for named product types i.e. Records with named fields"+      _ -> (gConfigSource @f def opts)+   where+    key :: Text+    key = T.pack $ conName @c undefined++-- | This is the type constructor case, if we are dealing with a+-- 'Cfg.Deriving.Config.ConfigRoot' instance, then we have to create an extra layer with the \"root+-- key\" as a key and then a subtree (calculated by recursively calling 'gConfigSource') as the value.+--+-- @since 0.0.2.0+instance (Datatype d, GConfigSource f) => GConfigSource (M1 D d f) where+  gConfigSource def opts =+    case opts of+      Root (RootOptions{rootOptionsRootKey = TypeName modifier}) ->+        Free $ singleton (modifier key) (gConfigSource @f def opts)+      _ -> (gConfigSource @f def opts)+   where+    key :: Text+    key = T.pack $ datatypeName @d undefined++-- | This instance handles product types and is pretty important. We need to+-- check that recursive calls to 'gConfigSource' generate sub-trees, and then+-- we merge the sub-trees.+--+-- You may wonder what happens if there is a 'Pure' value in one of the record+-- fields, well that would be represented like so:+--+-- @+-- Free $ M.singleton fieldName (Pure value)+-- @+--+-- since we need to account for the key corresponding to the record field. So+-- we really should never hit a case were a recursive call to 'gConfigSource'+-- yields a raw 'Pure'.+--+-- @since 0.0.2.0+instance (GConfigSource a, GConfigSource b) => GConfigSource (a :*: b) where+  gConfigSource def opts =+    case (gConfigSource @a def opts, gConfigSource @b def opts) of+      (Free m, Free m') -> Free $ m <> m'+      -- TODO: Would be nice if we could turn this into a compile time error.+      _ -> error "expected product types to generate subtrees (i.e. not contain Pure values)"++-- | Sum types should represent base values, so @Free M.empty@ is the right+-- thing to do here, although we should probably never hit this case, since sum+-- types should be nested under record fields as base values.+--+-- @since 0.0.2.0+instance GConfigSource (a :+: b) where+  gConfigSource _ _ = Free empty

@@ -0,0 +1,28 @@+-- |+--  Module      : Cfg.Source.Default+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module contains code related to defaulting.+module Cfg.Source.Default where++import Data.Text (Text)++-- TODO: Figure out a way to make this error when there is a nested record++-- | This class lets us represent defaults as a function from record field+-- names to 'Maybe' values. @Nothing@ represents the absence of a default, and+-- the default implementation is to always return @Nothing@.+--+-- @since 0.0.2.0+class DefaultSource a where+  defaults+    :: Text+    -- ^ Record field label+    -> Maybe Text+    -- ^ Serialized default+  defaults = const Nothing

@@ -1,58 +0,0 @@-module Cfg.Source.NestedConfig where--import Cfg.Options (ConfigOptions (..))-import Cfg.Source (NestedConfig (..))-import Data.Kind (Type)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Tree (Tree (..))-import GHC.Generics--defaultToNestedConfig :: forall a. (Generic a, GConfigForest (Rep a)) => ConfigOptions -> [Tree Text]-defaultToNestedConfig opts = gToForest @(Rep a) opts--{- | Generic typeclass machinery for inducting on the structure- of the type, such that we can thread `Display` instances through- the structure of the type. The primary use case is for implementing- `RecordInstance`, which does this "threading" for record fields. This- machinery does, crucially, depend on child types (i.e. the type of a- record field) having a `Display` instance.-- @since 0.0.1.0--}-class GConfigForest (a :: Type -> Type) where-    gToForest :: ConfigOptions -> [Tree Text]--instance GConfigForest V1 where-    gToForest _ = []--instance GConfigForest U1 where-    gToForest _ = []--instance NestedConfig a => GConfigForest (K1 R a) where-    gToForest _ = toNestedConfig @a--instance GConfigForest f => GConfigForest (M1 D s f) where-    gToForest opts = gToForest @f opts --instance (Constructor c, GConfigForest f) => GConfigForest (M1 C c f) where-    gToForest opts = gToForest @f opts--instance (Selector s, GConfigForest f) => GConfigForest (M1 S s f) where-    gToForest opts =-        if selName m == ""-            then error "Can only create a tree for named product types i.e. Records with named fields"-            else-                [ Node-                    (configOptionsLabelModifier opts $ T.pack (selName m))-                    (gToForest @f opts)-                ]-      where-        m :: t s f a-        m = undefined--instance (GConfigForest a, GConfigForest b) => GConfigForest (a :*: b) where-    gToForest opts = gToForest @a opts <> gToForest @b opts--instance GConfigForest (a :+: b) where-    gToForest _ = []

@@ -1,37 +0,0 @@-module Cfg.Source.RootConfig where--import Cfg.Options (RootOptions (..))-import Cfg.Source.NestedConfig-import Data.Kind (Type)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Tree (Tree (..))-import GHC.Generics--defaultToRootConfig :: forall a. (Generic a, GConfigTree (Rep a)) => RootOptions -> Tree Text-defaultToRootConfig opts = gToTree @(Rep a) opts--class GConfigTree (a :: Type -> Type) where-    gToTree :: RootOptions -> Tree Text---- TODO: Investigate whether this is required or not. Theoretically don't need this?------ instance RootConfig a => GConfigTree (K1 R a) where---   gToTree opts _ = toRootConfig opts (Proxy @a)--instance GConfigTree f => GConfigTree (M1 S s f) where-    gToTree opts = gToTree @f opts--instance GConfigTree f => GConfigTree (M1 D s f) where-    gToTree opts = gToTree @f opts--instance (Constructor c, GConfigForest f) => GConfigTree (M1 C c f) where-    gToTree opts-        | conIsRecord m =-            Node-                (rootOptionsLabelModifier opts . T.pack $ conName m)-                (gToForest @f $ rootOptionsFieldOptions opts)-        | otherwise = error "Can only create a tree for named product types i.e. Records with named fields"-      where-        m :: t c f a-        m = undefined

@@ -0,0 +1,161 @@+-- |+--  Module      : KeyTree+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @since 0.0.2.0+--+-- This module contains types for our internal tree representation of types and+-- configurations. It also contains some helper functions for working with+-- these trees. This should make it easier to implement different source+-- providers.+module KeyTree+  ( -- * Types+    KeyTree+  , KeyForest++    -- * Helper Functions+  , foldKeyTree+  , appendFold+  , mayAppendFold+  , appendTraverse+  , mayAppendTraverse++    -- * Type Re-exports+  , Map+  , Free (..)+  )+where++import Control.Monad.Free+import Data.Functor ((<&>))+import Data.Map.Strict++-- | Type alias for our internal tree structure. If this was written directly+-- as a sum type it would look like this:+--+-- @Pure value | Free (Map key (KeyTree key value))@+--+-- @since 0.0.2.0+type KeyTree key value = Free (Map key) value++-- | Type alias for a subtree+--+-- @since 0.0.2.0+type KeyForest key value = Map key (Free (Map key) value)++-- | Right fold on a 'KeyTree'. Uses 'Data.Map.foldrWithKey' under the hood.+--+-- @since 0.0.2.0+foldKeyTree+  :: (Eq k, Eq v)+  => (v -> a)+  -- ^ Function to run on 'Pure' values+  -> (k -> Free (Map k) v -> a -> a)+  -- ^ Step function for fold+  -> a+  -- ^ Initial accumulator+  -> KeyTree k v+  -- ^ KeyTree to fold+  -> a+foldKeyTree _ stepF acc (Free m) = foldrWithKey stepF acc m+foldKeyTree valF _ _ (Pure val) = valF val++-- | A fold that appends a value at the leaf of the 'KeyTree', identifies what to+-- insert at the leaf by running a function on an accumulated value.+--+-- @since 0.0.2.0+appendFold+  :: (Eq k, Eq v)+  => (a -> v -> v')+  -- ^ Function to run on existing 'Pure' leaves @a@ is the accumulator @v@ is the value in @Pure@.+  -> (a -> v')+  -- ^ Function from accumulator @a@ to a value @v@. This happens when an empty subtree is found.+  -> (k -> a -> Map k (Free (Map k) v) -> a)+  -- ^ Step function for fold with key @k@ as an argument.+  -> a+  -- ^ Accumulator.+  -> KeyTree k v+  -- ^ KeyTree to append values to.+  -> KeyTree k v'+appendFold valF accF stepF acc (Free m) =+  if m == empty+    then Pure $ accF acc+    else Free $ mapWithKey (\k a -> appendFold valF accF stepF (stepF k acc m) a) m+appendFold valF _ _ acc (Pure v) = Pure $ valF acc v++-- | A fold that appends a value at the leaf of the 'KeyTree' (like+-- 'appendFold'), but the function on the accumulator can return a 'Maybe'. In+-- the @Nothing@ case we just append a 'Free' full of an empty 'Data.Map.Map'.+--+-- @since 0.0.2.0+mayAppendFold+  :: (Eq k, Eq v)+  => (a -> v -> Maybe v')+  -- ^ Function to run on existing 'Pure' leaves.+  -> (a -> Maybe v')+  -- ^ Function to run when an empty node is found.+  -> (k -> a -> Map k (Free (Map k) v) -> a)+  -- ^ Step function for fold with key @k@ as an argument.+  -> a+  -- ^ Accumulator.+  -> KeyTree k v+  -- ^ Tree to be folded.+  -> KeyTree k v'+mayAppendFold valF accF stepF acc (Free m) =+  if m == empty+    then case accF acc of+      Nothing -> Free empty+      Just v -> Pure v+    else Free $ mapWithKey (\k a -> mayAppendFold valF accF stepF (stepF k acc m) a) m+mayAppendFold valF _ _ acc (Pure v) =+  case valF acc v of+    Nothing -> Free empty+    Just v' -> Pure v'++-- | Like 'appendFold' but with functions that return a value wrapped in an+-- 'Applicative' effect @f@. The function is suffixed with \"Traverse\" because+-- we use the 'sequenceA' to wrap the entire tree in a single 'Applicative'+-- effect.+--+-- @since 0.0.2.0+appendTraverse+  :: (Applicative f, Eq k, Eq v)+  => (a -> v -> f v')+  -- ^ Function to run on existing 'Pure' leaves.+  -> (a -> f v')+  -- ^ Function to run when an empty node is found.+  -> (k -> a -> Map k (Free (Map k) v) -> a)+  -- ^ Step function for fold with key @k@ as an argument.+  -> a+  -- ^ Accumulator.+  -> KeyTree k v+  -- ^ Tree to be folded.+  -> f (KeyTree k v')+appendTraverse valF accF stepF acc = sequenceA . appendFold valF accF stepF acc++-- | Similar to 'appendTraverse' except the 'Applicative' effect can optionally+-- return a result. The function is manually implemented rather than using+-- 'Traversable' methods so that we don't have to require 'Traversable' on @f@.+-- This allows consumers to use effects like 'IO' that don't have a+-- 'Traversable' instance.+--+-- @since 0.0.2.0+mayAppendTraverse+  :: (Applicative f, Eq k, Eq v)+  => (a -> v -> f v')+  -> (a -> f (Maybe v'))+  -> (k -> a -> Map k (Free (Map k) v) -> a)+  -> a+  -> KeyTree k v+  -> f (KeyTree k v')+mayAppendTraverse valF accF stepF acc (Free m) =+  if m == empty+    then+      accF acc <&> \case+        Nothing -> Free empty+        Just v -> Pure v+    else Free <$> traverseWithKey (\k v -> mayAppendTraverse valF accF stepF (stepF k acc m) v) m+mayAppendTraverse valF _ _ acc (Pure v) = Pure <$> valF acc v

@@ -1,41 +0,0 @@-module Tree.Append where--import Data.Functor-import Data.Tree (Tree (..))---- TODO: Come up with better names--appendLeaf :: (a -> b) -> ([a] -> b) -> [a] -> Tree a -> Tree b-appendLeaf f g acc (Node label []) = Node (f label) [Node (g (label : acc)) []]-appendLeaf f g acc (Node label xs) = Node (f label) $ fmap (appendLeaf f g (label : acc)) xs--mayAppendLeaf :: (a -> b) -> ([a] -> Maybe b) -> [a] -> Tree a -> Tree b-mayAppendLeaf f g acc (Node label []) =-  case g (label : acc) of-    Just leaf -> Node (f label) [Node leaf []]-    Nothing -> Node (f label) []-mayAppendLeaf f g acc (Node label xs) = Node (f label) $ fmap (mayAppendLeaf f g (label : acc)) xs--appendLeafA :: (Applicative f) => ([a] -> f a) -> [a] -> Tree a -> Tree (f a)-appendLeafA f acc = appendLeaf pure f acc--mayAppendLeafA :: (Applicative f) => ([a] -> Maybe (f a)) -> [a] -> Tree a -> Tree (f a)-mayAppendLeafA f acc = mayAppendLeaf pure f acc--mayAppendLeafA' :: (Applicative f) => ([a] -> f (Maybe a)) -> [a] -> Tree a -> f (Tree a)-mayAppendLeafA' f acc (Node label []) =-  f (label : acc)-    <&> \case-      Just leaf -> Node label [Node leaf []]-      Nothing -> Node label []-mayAppendLeafA' f acc (Node label xs) =-  let-    trees = traverse (mayAppendLeafA' f (label : acc)) xs-  in-    Node label <$> trees--travAppendLeafA :: (Applicative f) => ([a] -> f a) -> [a] -> Tree a -> f (Tree a)-travAppendLeafA f acc = sequenceA . appendLeaf pure f acc--travMayAppendLeafA :: (Traversable f, Applicative f) => ([a] -> f (Maybe a)) -> [a] -> Tree a -> f (Tree a)-travMayAppendLeafA f acc = sequenceA . mayAppendLeaf pure (sequenceA . f) acc

@@ -0,0 +1,54 @@+module Cfg.Deriving.KeyModifierSpec where++import Cfg.Deriving.KeyModifier+import Test.Hspec++spec :: Spec+spec = do+  describe "basic modifiers" $ do+    it "ToLower" $ do+      let+        text = "ThisShouldBeLower1234"+      getKeyModifier @ToLower text `shouldBe` "thisshouldbelower1234"+    it "ToUpper" $ do+      let+        text = "ThisShouldBeUpper1234"+      getKeyModifier @ToUpper text `shouldBe` "THISSHOULDBEUPPER1234"+    it "LowerFirst" $ do+      let+        text = "ThisShouldBeLower1234"+      getKeyModifier @LowerFirst text `shouldBe` "thisShouldBeLower1234"+    it "UpperFirst" $ do+      let+        text = "thisShouldBeLower1234"+      getKeyModifier @UpperFirst text `shouldBe` "ThisShouldBeLower1234"+    it "StripPrefix" $ do+      let+        text = "someConvalutedRecordNameRecordValue"+      getKeyModifier @(StripPrefix "someConvalutedRecordName") text+        `shouldBe` "RecordValue"+    it "StripSuffix" $ do+      let+        text = "superCoolApplicationConfig"+      getKeyModifier @(StripSuffix "Config") text+        `shouldBe` "superCoolApplication"+    it "CamelToSnake" $ do+      let+        text = "superCoolApplicationConfig"+      getKeyModifier @CamelToSnake text+        `shouldBe` "super_cool_application_config"+    it "CamelToKebab" $ do+      let+        text = "superCoolApplicationConfig"+      getKeyModifier @CamelToKebab text+        `shouldBe` "super-cool-application-config"+    it "should work as a list, applied in left to right order" $ do+      let+        text = "superCoolApplicationConfig"+      getKeyModifier @[StripSuffix "Config", CamelToSnake, ToUpper] text+        `shouldBe` "SUPER_COOL_APPLICATION"+    it "should work as a tuple, applied in left to right order" $ do+      let+        text = "superCoolApplicationConfig"+      getKeyModifier @(StripSuffix "Config", CamelToSnake, ToUpper) text+        `shouldBe` "SUPER_COOL_APPLICATION"

@@ -0,0 +1,99 @@+module Cfg.Env.KeysSpec where++import Cfg.Deriving+import Cfg.Deriving.KeyModifier+import Cfg.Env.Keys+import Cfg.Options+import Cfg.Source (ConfigSource)+import Cfg.Source.Default+import Data.Map.Strict (empty, fromList, singleton)+import Data.Text (Text)+import GHC.Generics+import KeyTree+import Test.Hspec++spec :: Spec+spec = do+  describe "getKeys" $ do+    it "should collect all tree keys" $ do+      let+        tree :: KeyTree Text Text =+          Free $+            fromList+              [ ("A", Pure "Case1")+              ,+                ( "B"+                , Free $+                    fromList+                      [ ("1", Pure "Hello World")+                      , ("2", Pure "27")+                      , ("3", Pure "True")+                      , ("4", Free empty)+                      ]+                )+              , ("C", Pure "18")+              ,+                ( "D"+                , Free $+                    singleton "E" $+                      Free $+                        singleton "F" $+                          Free $+                            singleton "G" $+                              Free $+                                singleton "H" $+                                  Free $+                                    singleton "I" $+                                      Free $+                                        singleton "J" $+                                          Free $+                                            singleton "K" $+                                              Pure "[1,2,3,4]"+                )+              ]+      let+        expected =+          [ ["A"]+          , ["B", "1"]+          , ["B", "2"]+          , ["B", "3"]+          , ["B", "4"]+          , ["C"]+          , ["D", "E", "F", "G", "H", "I", "J", "K"]+          ]+      getKeys tree `shouldBe` expected+  describe "showEnvKeys" $ do+    it "should concatenate all tree keys with separator" $ do+      let+        expected =+          [ "ROOT_DATA_CON_OPTS__KEY_OPTS1"+          , "ROOT_DATA_CON_OPTS__KEY_OPTS2__SUB_KEY_OPTS1"+          , "ROOT_DATA_CON_OPTS__KEY_OPTS2__SUB_KEY_OPTS2"+          , "ROOT_DATA_CON_OPTS__KEY_OPTS2__SUB_KEY_OPTS3"+          , "ROOT_DATA_CON_OPTS__KEY_OPTS3"+          , "ROOT_DATA_CON_OPTS__KEY_OPTS4"+          ]+      showEnvKeys @(RootTyConOpts Text) "__" `shouldBe` expected++data SumTypeConfig = Case1 | Case2+  deriving stock (Generic, Show)+  deriving (ConfigSource) via Value SumTypeConfig++data SubTyConOpts = SubDataConOpts+  { subKeyOpts1 :: Text+  , subKeyOpts2 :: Int+  , subKeyOpts3 :: Maybe Bool+  }+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource) via (ConfigOpts [CamelToSnake, ToUpper] SubTyConOpts)++data RootTyConOpts a = RootDataConOpts+  { keyOpts1 :: SumTypeConfig+  , keyOpts2 :: SubTyConOpts+  , keyOpts3 :: Int+  , keyOpts4 :: a+  }+  deriving (Generic, Show, DefaultSource)+  deriving+    (ConfigSource)+    via (ConfigRoot ('ConstructorName [CamelToSnake, ToUpper]) [CamelToSnake, ToUpper] (RootTyConOpts a))

@@ -1,92 +1,73 @@ module Cfg.EnvSpec where -import Cfg.Env (envSource)-import Control.Monad.Identity+import Cfg.Env+import Data.Map.Strict (empty, fromList, singleton) import Data.Text (Text)-import Data.Tree (Tree (..))-import System.Environment (setEnv)+import KeyTree+import System.Environment (setEnv, unsetEnv) import Test.Hspec-import Tree.Append+import Test.Hspec.Core.Spec (sequential)  spec :: Spec-spec = do-  describe "appendLeaf" $ do-    it "should append the prefix of node keys as a leaf" $ do-      let-        tree :: Tree Text = Node "A" [Node "B" [], Node "C" [], Node "D" []]+spec = around+  ( \runTest -> do+      setEnv "A_B" "Functor"+      setEnv "A_C" "Applicative"+      setEnv "A_D" "Monad"+      runTest ()+      unsetEnv "A_B"+      unsetEnv "A_C"+      unsetEnv "A_D"+  )+  $ sequential+  $ describe "envSource"+  $ do+    it "should get variables from environment" $ do       let-        expected =-          Node-            "A"-            [ Node "B" [Node "AB" []]-            , Node "C" [Node "AC" []]-            , Node "D" [Node "AD" []]-            ]-      appendLeaf id (foldr (\x acc -> acc <> x) "") [] tree `shouldBe` expected+        tree :: KeyTree Text Text =+          Free $+            singleton "A" $+              Free $+                fromList+                  [ ("B", Free empty)+                  , ("C", Free empty)+                  , ("D", Free empty)+                  ] -  describe "appendLeafA" $ do-    it "should append the prefix of node keys as a leaf with Identity" $ do       let-        tree :: Tree Text = Node "A" [Node "B" [], Node "C" [], Node "D" []]-      let         expected =-          Node-            (Identity "A")-            [ Node (Identity "B") [Node (Identity "AB") []]-            , Node (Identity "C") [Node (Identity "AC") []]-            , Node (Identity "D") [Node (Identity "AD") []]-            ]-      appendLeafA (pure . foldr (\x acc -> acc <> x) "") [] tree `shouldBe` expected--  describe "travAppendLeafA" $ do-    it "should append the prefix of node keys as a leaf with Just" $ do-      let-        tree :: Tree Text = Node "A" [Node "B" [], Node "C" [], Node "D" []]-      let-        expected =-          Just $-            Node-              "A"-              [ Node "B" [Node "AB" []]-              , Node "C" [Node "AC" []]-              , Node "D" [Node "AD" []]-              ]-      travAppendLeafA (pure . foldr (\x acc -> acc <> x) "") [] tree `shouldBe` expected--    it "should be Nothing when the leaves are Nothing" $ do-      let-        tree :: Tree Text = Node "A" [Node "B" [], Node "C" [], Node "D" []]-      travAppendLeafA (const Nothing) [] tree `shouldBe` Nothing--  describe "envSource" $ do-    it "Should get environment variables that are in the environment" $ do-      let-        tree :: Tree Text = Node "A" [Node "B" [], Node "C" [], Node "D" []]-      let-        expected =-          Just $-            Node-              "A"-              [ Node "B" [Node "AB" []]-              , Node "C" [Node "AC" []]-              , Node "D" [Node "AD" []]-              ]-      travAppendLeafA (pure . foldr (\x acc -> acc <> x) "") [] tree `shouldBe` expected--    it "should be Nothing when the leaves are Nothing" $ do-      setEnv "A_B" "Functor"-      setEnv "A_C" "Applicative"-      setEnv "A_D" "Monad"+          Free $+            singleton "A" $+              Free $+                fromList+                  [ ("B", Pure "Functor")+                  , ("C", Pure "Applicative")+                  , ("D", Pure "Monad")+                  ]+      result <- envSource tree+      result `shouldBe` expected+    it "should respect defaults" $ do+      unsetEnv "A_C"       let-        tree :: Tree Text = Node "A" [Node "B" [], Node "C" [], Node "D" []]+        tree :: KeyTree Text Text =+          Free $+            singleton "A" $+              Free $+                fromList+                  [ ("B", Pure "Traversable")+                  , ("C", Pure "Applicative")+                  , ("D", Free empty)+                  ]        let         expected =-          Node-            "A"-            [ Node "B" [Node "Functor" []]-            , Node "C" [Node "Applicative" []]-            , Node "D" [Node "Monad" []]-            ]+          Free $+            singleton "A" $+              Free $+                fromList+                  [ ("B", Pure "Functor")+                  , ("C", Pure "Applicative")+                  , ("D", Pure "Monad")+                  ]       result <- envSource tree       result `shouldBe` expected

@@ -1,26 +1,27 @@ module Cfg.ParserSpec where -import Cfg.Deriving.ConfigRoot (ConfigRoot (..))-import Cfg.Deriving.ConfigValue-import Cfg.Deriving.SubConfig (SubConfig (..))+import Cfg.Deriving.Config+import Cfg.Deriving.Value import Cfg.Parser+import Data.Map.Strict (empty, fromList) import Data.Text (Text)-import Data.Tree (Tree (..)) import GHC.Generics (Generic (..))+import KeyTree import Test.Hspec  data SumTypeConfig = Case1 | Case2   deriving stock (Generic, Show, Eq)-  deriving (ValueParser) via (ConfigValue SumTypeConfig)-  deriving (NestedParser)+  deriving (ValueParser) via (Value SumTypeConfig)+  deriving (ConfigParser)  data SubTyCon = SubDataCon   { subKey1 :: Text   , subKey2 :: Int   , subKey3 :: Maybe Bool+  , subKey4 :: Maybe Bool   }   deriving (Generic, Show, Eq)-  deriving (NestedParser) via (SubConfig SubTyCon)+  deriving (ConfigParser) via (Config SubTyCon)  data RootTyCon a = RootDataCon   { key1 :: SumTypeConfig@@ -29,28 +30,32 @@   , key4 :: a   }   deriving stock (Generic, Show, Eq)-  deriving (RootParser) via (ConfigRoot (RootTyCon a))+  deriving (ConfigParser) via (Config (RootTyCon a))  spec :: Spec spec = do-  describe "toRootConfig" $ do+  describe "toConfig" $ do     it "should parse a type from the sample config" $ do       let-        subConfig = SubDataCon "Hello World" 27 (Just True)+        subConfig = SubDataCon "Hello World" 27 (Just True) Nothing       let         expected :: RootTyCon [Int] = RootDataCon Case1 subConfig 18 [1, 2, 3, 4]       let         underTest =-          Node-            "RootDataCon"-            [ Node "key1" [Node "Case1" []]-            , Node-                "key2"-                [ Node "subKey1" [Node "Hello World" []]-                , Node "subKey2" [Node "27" []]-                , Node "subKey3" [Node "Just True" []]-                ]-            , Node "key3" [Node "18" []]-            , Node "key4" [Node "[1,2,3,4]" []]-            ]-      parseRootConfig underTest `shouldBe` (Right expected)+          Free $+            fromList+              [ ("key1", Pure "Case1")+              ,+                ( "key2"+                , Free $+                    fromList+                      [ ("subKey1", Pure "Hello World")+                      , ("subKey2", Pure "27")+                      , ("subKey3", Pure "True")+                      , ("subKey4", Free empty)+                      ]+                )+              , ("key3", Pure "18")+              , ("key4", Pure "[1,2,3,4]")+              ]+      parseConfig underTest `shouldBe` (Right expected)

@@ -1,62 +1,94 @@ module Cfg.SourceSpec where -import Cfg.Deriving.ConfigRoot-import Cfg.Deriving.ConfigValue-import Cfg.Deriving.LabelModifier-import Cfg.Deriving.SubConfig+import Cfg.Deriving.Config+import Cfg.Deriving.KeyModifier+import Cfg.Deriving.Value+import Cfg.Options+import Cfg.Parser import Cfg.Source+import Cfg.Source.Default+import Data.Map.Strict (empty, fromList, singleton) import Data.Text (Text)-import Data.Tree (Tree (..)) import GHC.Generics (Generic (..))+import KeyTree import Test.Hspec  spec :: Spec spec = do-  describe "toRootConfig" $ do+  describe "configSource" $ do     it "should create a tree from the sample config" $ do       let         expected =-          Node-            "RootDataCon"-            [ Node "key1" []-            , Node-                "key2"-                [ Node "subKey1" []-                , Node "subKey2" []-                , Node "subKey3" []-                ]-            , Node "key3" []-            , Node "key4" []-            ]-      toRootConfig @(RootTyCon Text) `shouldBe` expected+          Free $+            fromList+              [ ("key1", Free empty)+              ,+                ( "key2"+                , Free $+                    fromList+                      [ ("subKey1", Free empty)+                      , ("subKey2", Free empty)+                      , ("subKey3", Free empty)+                      ]+                )+              , ("key3", Free empty)+              , ("key4", Free empty)+              ]+      configSource @(RootTyCon Text) `shouldBe` expected     it "should create a tree with modified options from sample config" $ do       let         expected =-          Node-            "ROOTDATACONOPTS"-            [ Node "keyopts1" []-            , Node-                "keyopts2"-                [ Node "SUBKEY1" []-                , Node "SUBKEY2" []-                , Node "SUBKEY3" []-                ]-            , Node "keyopts3" []-            , Node "keyopts4" []-            ]-      toRootConfig @(RootTyConOpts Text) `shouldBe` expected+          Free $+            singleton "ROOTTYCONOPTS" $+              Free $+                fromList+                  [ ("keyopts1", Free empty)+                  ,+                    ( "keyopts2"+                    , Free $+                        fromList+                          [ ("SUBKEYOPTS1", Free empty)+                          , ("SUBKEYOPTS2", Free empty)+                          , ("SUBKEYOPTS3", Free empty)+                          ]+                    )+                  , ("keyopts3", Free empty)+                  , ("keyopts4", Free empty)+                  ]+      configSource @(RootTyConOpts Text) `shouldBe` expected+    it "should create a tree with modified options from sample config AND respect defaults" $ do+      let+        expected =+          Free $+            singleton "ROOTTYCONOPTSDEF" $+              Free $+                fromList+                  [ ("keyoptsdef1", Pure "Case1")+                  ,+                    ( "keyoptsdef2"+                    , Free $+                        fromList+                          [ ("SUBKEYOPTS1", Free empty)+                          , ("SUBKEYOPTS2", Free empty)+                          , ("SUBKEYOPTS3", Free empty)+                          ]+                    )+                  , ("keyoptsdef3", Free empty)+                  , ("keyoptsdef4", Free empty)+                  ]+      configSource @(RootTyConOptsDef Text) `shouldBe` expected  data SumTypeConfig = Case1 | Case2-  deriving stock (Generic, Show)-  deriving (NestedConfig) via ConfigValue SumTypeConfig+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource) via Value SumTypeConfig  data SubTyCon = SubDataCon   { subKey1 :: Text   , subKey2 :: Int   , subKey3 :: Maybe Bool   }-  deriving (Generic, Show)-  deriving (NestedConfig) via (SubConfig SubTyCon)+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource) via (Config SubTyCon)  data RootTyCon a = RootDataCon   { key1 :: SumTypeConfig@@ -64,16 +96,16 @@   , key3 :: Int   , key4 :: a   }-  deriving stock (Generic, Show)-  deriving (RootConfig) via (ConfigRoot (RootTyCon a))+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource) via (Config (RootTyCon a))  data SubTyConOpts = SubDataConOpts   { subKeyOpts1 :: Text   , subKeyOpts2 :: Int   , subKeyOpts3 :: Maybe Bool   }-  deriving (Generic, Show)-  deriving (NestedConfig) via (SubConfigOpts ToUpper SubTyCon)+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource) via (ConfigOpts ToUpper SubTyConOpts)  data RootTyConOpts a = RootDataConOpts   { keyOpts1 :: SumTypeConfig@@ -81,5 +113,18 @@   , keyOpts3 :: Int   , keyOpts4 :: a   }-  deriving stock (Generic, Show)-  deriving (RootConfig) via (ConfigRootOpts ToUpper ToLower (RootTyConOpts a))+  deriving (Generic, Show, DefaultSource)+  deriving (ConfigSource) via (ConfigRoot ('TypeName ToUpper) ToLower (RootTyConOpts a))++data RootTyConOptsDef a = RootTyConOptsDef+  { keyOptsDef1 :: SumTypeConfig+  , keyOptsDef2 :: SubTyConOpts+  , keyOptsDef3 :: Int+  , keyOptsDef4 :: a+  }+  deriving (Generic, Show)+  deriving (ConfigSource) via (ConfigRoot ('TypeName ToUpper) ToLower (RootTyConOptsDef a))++instance DefaultSource (RootTyConOptsDef a) where+  defaults "keyOptsDef1" = Just "Case1"+  defaults _ = Nothing

@@ -11,12 +11,14 @@  main :: IO () main = do-    mText <- lookupEnv "TEST_CONCURRENCY"-    let maxResources :: Int-        maxResources = fromMaybe 8 (mText >>= readMaybe)-    let cfg =-            TR.defaultConfig-                { configConcurrentJobs = Just maxResources-                , configFormatter = Just specdoc-                }-    hspecWith cfg (parallel Spec.spec)+  mText <- lookupEnv "TEST_CONCURRENCY"+  let+    maxResources :: Int+    maxResources = fromMaybe 8 (mText >>= readMaybe)+  let+    cfg =+      TR.defaultConfig+        { configConcurrentJobs = Just maxResources+        , configFormatter = Just specdoc+        }+  hspecWith cfg (parallel Spec.spec)