packages feed

cfg (empty) → 0.0.1.0

raw patch · 24 files changed

+1823/−0 lines, 24 filesdep +basedep +bytestringdep +cfg

Dependencies added: base, bytestring, cfg, containers, errors, hedgehog, hspec, hspec-core, hspec-discover, hspec-expectations, hspec-hedgehog, megaparsec, mtl, pretty-simple, text, vector

Files

+ LICENSE view
@@ -0,0 +1,7 @@+Copyright 2023 Jonathan Lorimer <jonathanlorimer@pm.me>++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ cfg.cabal view
@@ -0,0 +1,133 @@+cabal-version: 3.0+name:          cfg+version:       0.0.1.0+synopsis:      Type generated application configuration +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 +  "sources" for configuration access, the environment source is provided in this package as a default.++category:      Configuration+bug-reports:   https://github.com/JonathanLorimer/cfg/issues+homepage:      https://github.com/JonathanLorimer/cfg#readme+license:       MIT+license-file:  LICENSE+copyright:     (c) 2023 Jonathan Lorimer+author:        Jonathan Lorimer+maintainer:    Jonathan Lorimer <jonathanlorimer@pm.me>+build-type:    Simple++source-repository head+  type:     git+  location: https://github.com/JonathanLorimer/cfg++common common-opts+  default-extensions:+    AllowAmbiguousTypes+    BlockArguments+    ConstraintKinds+    DataKinds+    DeriveAnyClass+    DeriveFunctor+    DeriveGeneric+    DerivingStrategies+    DerivingVia+    EmptyCase+    FlexibleContexts+    FlexibleInstances+    GADTs+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    InstanceSigs+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    NamedFieldPuns+    NumericUnderscores+    OverloadedStrings+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators++  build-depends:+    , base           >=4.18.0 && <4.19+    , containers     >=0.6.7  && <0.7+    , mtl            >=2.3.1  && <2.4+    , pretty-simple+    , text           >=2.0.2  && <2.1++  default-language:   Haskell2010++library+  import:          common-opts+  build-depends:+    , bytestring  >=0.11.4 && <0.12+    , errors      >=2.3.0  && <2.4+    , megaparsec  >=9.2.2  && <9.3+    , vector      >=0.12.3 && <0.13++  -- cabal-fmt: expand src+  exposed-modules:+    Cfg+    Cfg.Deriving+    Cfg.Deriving.Assert+    Cfg.Deriving.ConfigRoot+    Cfg.Deriving.ConfigValue+    Cfg.Deriving.LabelModifier+    Cfg.Deriving.SubConfig+    Cfg.Env+    Cfg.Env.Keys+    Cfg.Options+    Cfg.Parser+    Cfg.Parser.ConfigParser+    Cfg.Parser.ValueParser+    Cfg.Source+    Cfg.Source.NestedConfig+    Cfg.Source.RootConfig+    Tree.Append++  hs-source-dirs:  src+  ghc-options:     -Wall -fdefer-typed-holes++test-suite cfg-tests+  import:         common-opts+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  ghc-options:+    -Wall -threaded -rtsopts -with-rtsopts=-N -fdefer-typed-holes++  main-is:        Main.hs++  -- cabal-fmt: expand test -Main+  other-modules:+    Cfg.EnvSpec+    Cfg.ParserSpec+    Cfg.SourceSpec+    Spec++  build-depends:+    , cfg+    , hedgehog            >=1.2   && <1.3+    , hspec               >=2.9.7 && <2.10+    , hspec-core          >=2.9.7 && <2.10+    , hspec-discover      >=2.9.7 && <2.10+    , 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
+ src/Cfg.hs view
@@ -0,0 +1,544 @@+-- |+--  Module      : Cfg+--  Copyright   : © Jonathan Lorimer, 2023+--  License     : MIT+--  Maintainer  : jonathanlorimer@pm.me+--  Stability   : stable+--+-- @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 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.+--+-- While this package provides a default source (environment variables), the+-- intention is that other packages will provide additional sources.++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).++-- * 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++-- ** 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)+-- @++-- ** 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 = []+--             }+--         ]+--     }++-- ** 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+--         }+--     )++-- ** 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"+-- ]++-- * Exports+--+-- |+--++  getConfigRaw,+  getConfig,+) where+++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(..))++-- Imports for examples+import GHC.Generics+import Data.ByteString (ByteString)+import Cfg.Deriving.SubConfig (SubConfig(..))+import Cfg.Deriving.LabelModifier (ToUpper)+import Cfg.Deriving.ConfigRoot (ConfigRootOpts(..))+import Cfg.Deriving.SubConfig (SubConfigOpts(..))++-- | @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++-- | @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)+++-------------------------------------------------------+-- Examples for haddocks+-------------------------------------------------------+data Environment = Development | Production+  deriving stock (Generic, Show)+  deriving (NestedConfig) via ConfigValue Environment+  deriving (ValueParser) via ConfigValue Environment+  deriving NestedParser++data WarpConfig = WarpConfig+  { warpConfigPort :: Int+  , warpConfigTimeout :: Int+  , warpConfigHTTP2Enabled :: Bool+  , warpConfigServerName :: ByteString+  }+  deriving (Generic, Show)+  deriving (NestedConfig) via (SubConfig WarpConfig)+  deriving (NestedParser) via (SubConfig WarpConfig)++data RedisConfig = RedisConfig+  { redisConfigHost :: Text+  , redisConfigPort :: Int+  , redisConfigConnectAuth :: Maybe ByteString+  }+  deriving (Generic, Show)+  deriving (NestedConfig) via (SubConfig RedisConfig)+  deriving (NestedParser) via (SubConfig RedisConfig)++data AppConfig = AppConfig+  { appConfigWarpSettings :: WarpConfig+  , appConfigRedisSettings :: RedisConfig+  , appConfigEnvironment :: Environment+  }+  deriving stock (Generic, Show)+  deriving (RootConfig) via (ConfigRoot AppConfig)+  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" [] ]+            }+        ]+    }++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)
+ src/Cfg/Deriving.hs view
@@ -0,0 +1,12 @@+module Cfg.Deriving+  ( module Cfg.Deriving.ConfigRoot+  , module Cfg.Deriving.ConfigValue+  , module Cfg.Deriving.SubConfig+  , module Cfg.Deriving.LabelModifier+  )+where++import Cfg.Deriving.ConfigRoot+import Cfg.Deriving.ConfigValue+import Cfg.Deriving.LabelModifier+import Cfg.Deriving.SubConfig
+ src/Cfg/Deriving/Assert.hs view
@@ -0,0 +1,29 @@+module Cfg.Deriving.Assert where++import Data.Kind (Type)+import GHC.Base (Constraint)+import GHC.Generics+import GHC.TypeError (ErrorMessage (..), TypeError)++class Assert (pred :: Bool) (msg :: ErrorMessage)+instance Assert 'True msg+instance TypeError msg ~ '() => Assert 'False msg++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++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."+        )
+ src/Cfg/Deriving/ConfigRoot.hs view
@@ -0,0 +1,52 @@+{-# 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
+ src/Cfg/Deriving/ConfigValue.hs view
@@ -0,0 +1,19 @@+{-# 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)
+ src/Cfg/Deriving/LabelModifier.hs view
@@ -0,0 +1,22 @@+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
+ src/Cfg/Deriving/SubConfig.hs view
@@ -0,0 +1,46 @@+{-# 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
+ src/Cfg/Env.hs view
@@ -0,0 +1,55 @@+module Cfg.Env where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.List (intersperse)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO (writeFile)+import Data.Tree (Tree)+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+envSourceSep+  :: forall m+   . (MonadFail m, MonadIO m)+  => Text+  -> Tree Text+  -> m (Tree Text)+envSourceSep sep = mayAppendLeafA' getLeafFromEnv []+ where+  getLeafFromEnv :: [Text] -> m (Maybe Text)+  getLeafFromEnv keys = do+    let+      key = foldr (flip mappend) "" $ intersperse sep keys++    liftIO $ (fmap T.pack) <$> (lookupEnv $ T.unpack key)++-- | @since 0.0.1.0+envSource :: (MonadFail m, MonadIO m) => Tree Text -> m (Tree Text)+envSource = envSourceSep "_"++-- | @since 0.0.1.0+printDotEnv' :: FilePath -> Text -> Tree Text -> 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)+getEnvConfigSep sep = getConfig $ envSourceSep sep++-- | @since 0.0.1.0+getEnvConfig :: (MonadFail m, MonadIO m, RootConfig a, RootParser a) => m (Either ConfigParseError a)+getEnvConfig = getConfig $ envSource++-- | @since 0.0.1.0+printDotEnv :: forall a. (RootConfig a) => FilePath -> IO ()+printDotEnv path =+  writeFile path+    . foldMap (\line -> "export " <> line <> "=\n")+    . showEnvKeys' "_"+    $ toRootConfig @a
+ src/Cfg/Env/Keys.hs view
@@ -0,0 +1,27 @@+module Cfg.Env.Keys where++import Data.Text (Text)+import Data.Tree (Tree, foldTree)+import Cfg.Source (RootConfig (..))+import Data.List (intersperse)++-- | @since 0.0.1.0+getEnvKey :: Text -> [Text] -> Text+getEnvKey sep = foldr mappend "" . intersperse sep++-- | @since 0.0.1.0+getKeys :: Tree Text -> [[Text]]+getKeys = foldTree f+ where+  f :: Text -> [[[Text]]] -> [[Text]]+  f label [] = [[label]]+  f label xs = concat $ fmap (label :) <$> xs++-- | @since 0.0.1.0+showEnvKeys' :: Text -> Tree Text -> [Text]+showEnvKeys' sep tree = getEnvKey sep <$> getKeys tree++-- | @since 0.0.1.0+showEnvKeys :: forall a. (RootConfig a) => Text -> [Text]+showEnvKeys sep = getEnvKey sep <$> (getKeys $ toRootConfig @a)+
+ src/Cfg/Options.hs view
@@ -0,0 +1,17 @@+module Cfg.Options where++import Data.Text (Text)++data RootOptions = RootOptions+  { rootOptionsLabelModifier :: Text -> Text+  , rootOptionsFieldOptions :: ConfigOptions+  }++defaultRootOptions :: RootOptions+defaultRootOptions = RootOptions id (ConfigOptions id)++data ConfigOptions = ConfigOptions+  {configOptionsLabelModifier :: Text -> Text}++defaultConfigOptions :: ConfigOptions+defaultConfigOptions = ConfigOptions id
+ src/Cfg/Parser.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE DefaultSignatures #-}++module Cfg.Parser where++import Control.Error (note)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Data.Functor (void, ($>))+import Data.Int+import Data.List.NonEmpty (NonEmpty, fromList)+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 Text.Megaparsec.Char (char, digitChar, space1, string, string')+import Text.Megaparsec.Char.Lexer qualified as L++type Parser = Parsec Void Text++data ConfigParseError+  = UnmatchedFields [Tree Text]+  | MismatchedRootKey Text Text+  | MismatchedKeyAndField Text (Text, Text)+  | MissingKeys [Text]+  | MissingValue Text+  | UnexpectedKeys Text [Tree Text]+  | ValueParseError Text+  deriving (Eq, Show, Generic)++class RootParser a where+  parseRootConfig :: Tree Text -> Either ConfigParseError a++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++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 ()++-- | @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++-- | @since 0.0.1.0+instance ValueParser Char where+  parser = anySingle++-- | @since 0.0.1.0+instance NestedParser Char++-- | @since 0.0.1.0+instance ValueParser TL.Text where+  parser = TL.fromStrict <$> takeRest++-- | @since 0.0.1.0+instance NestedParser 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++-- | @since 0.0.1.0+instance ValueParser BS.ByteString where+  parser = encodeUtf8 <$> takeRest++-- | @since 0.0.1.0+instance NestedParser BS.ByteString++-- @since 0.0.1.0+instance ValueParser Text where+  parser = takeRest++-- | @since 0.0.1.0+instance NestedParser Text++-- | @since 0.0.1.0+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]++-- | @since 0.0.1.0+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)++-- | @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)++-- Numeric Types++rd :: Read a => Text -> a+rd = read . T.unpack++plus :: Parser Text+plus = char '+' >> number++minus :: Parser Text+minus = liftA2 (T.cons) (char '-') number++number :: Parser Text+number = T.pack <$> some digitChar++decimal :: Parser Text+decimal = option "" $ (T.cons) <$> char '.' <*> number++integral :: (Read a) => Parser a+integral = rd <$> (try plus <|> try minus <|> number)++fractional :: (Read a) => Parser a+fractional = fmap rd $ liftA2 (<>) integral decimal++-- | @since 0.0.1.0+instance ValueParser Double where+  parser = fractional++instance NestedParser Double++-- | @since 0.0.1.0+instance ValueParser Float where+  parser = fractional++instance NestedParser Float++-- @since 0.0.1.0+instance ValueParser Int where+  parser = integral++instance NestedParser Int++-- | @since 0.0.1.0+instance ValueParser Int8 where+  parser = integral++instance NestedParser Int8++-- | @since 0.0.1.0+instance ValueParser Int16 where+  parser = integral++instance NestedParser Int16++-- | @since 0.0.1.0+instance ValueParser Int32 where+  parser = integral++instance NestedParser Int32++-- | @since 0.0.1.0+instance ValueParser Int64 where+  parser = integral++instance NestedParser Int64++-- | @since 0.0.1.0+instance ValueParser Integer where+  parser = integral++instance NestedParser Integer++-- | @since 0.0.1.0+instance ValueParser Word where+  parser = rd <$> number++instance NestedParser Word++-- | @since 0.0.1.0+instance ValueParser Word8 where+  parser = rd <$> number++instance NestedParser Word8++-- | @since 0.0.1.0+instance ValueParser Word16 where+  parser = rd <$> number++instance NestedParser Word16++-- | @since 0.0.1.0+instance ValueParser Word32 where+  parser = rd <$> number++instance NestedParser Word32++-- | @since 0.0.1.0+instance ValueParser Word64 where+  parser = rd <$> number++instance NestedParser Word64++-- | @since 0.0.1.0+instance (ValueParser a, ValueParser b) => ValueParser (a, b) where+  parser = between (L.symbol sp "(") (L.symbol sp ")") $ do+    a <- parser @a+    void $ L.symbol sp ","+    b <- parser @b+    pure (a, b)++-- | @since 0.0.1.0+instance (ValueParser a, ValueParser b) => NestedParser (a, b)
+ src/Cfg/Parser/ConfigParser.hs view
@@ -0,0 +1,94 @@+{-# 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
+ src/Cfg/Parser/ValueParser.hs view
@@ -0,0 +1,41 @@+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)
+ src/Cfg/Source.hs view
@@ -0,0 +1,102 @@+module Cfg.Source where++import Cfg.Deriving.ConfigValue (ConfigValue)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Data.Int+import Data.List.NonEmpty+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)++-- | @since 0.0.1.0+class RootConfig a where+  toRootConfig :: Tree Text++-- | @since 0.0.1.0+class NestedConfig a where+  toNestedConfig :: [Tree Text]++-- | @since 0.0.1.0+instance NestedConfig (ConfigValue a) where+  toNestedConfig = []++-- | @since 0.0.1.0+deriving via (ConfigValue ()) instance NestedConfig ()++-- | @since 0.0.1.0+deriving via (ConfigValue Bool) instance NestedConfig Bool++-- | @since 0.0.1.0+deriving via (ConfigValue Char) instance NestedConfig Char++-- | @since 0.0.1.0+deriving via (ConfigValue TL.Text) instance NestedConfig TL.Text++-- | @since 0.0.1.0+deriving via (ConfigValue BL.ByteString) instance NestedConfig BL.ByteString++-- | @since 0.0.1.0+deriving via (ConfigValue BS.ByteString) instance NestedConfig BS.ByteString++-- | @since 0.0.1.0+deriving via (ConfigValue Text) instance NestedConfig Text++-- | @since 0.0.1.0+deriving via (ConfigValue [a]) instance NestedConfig [a]++-- | @since 0.0.1.0+deriving via (ConfigValue (NonEmpty a)) instance NestedConfig (NonEmpty a)++-- | @since 0.0.1.0+deriving via (ConfigValue (Vector a)) instance NestedConfig (Vector a)++-- | @since 0.0.1.0+deriving via (ConfigValue (Maybe a)) instance NestedConfig (Maybe a)++-- | @since 0.0.1.0+deriving via (ConfigValue Double) instance NestedConfig Double++-- | @since 0.0.1.0+deriving via (ConfigValue Float) instance NestedConfig Float++-- | @since 0.0.1.0+deriving via (ConfigValue Int) instance NestedConfig Int++-- | @since 0.0.1.0+deriving via (ConfigValue Int8) instance NestedConfig Int8++-- | @since 0.0.1.0+deriving via (ConfigValue Int16) instance NestedConfig Int16++-- | @since 0.0.1.0+deriving via (ConfigValue Int32) instance NestedConfig Int32++-- | @since 0.0.1.0+deriving via (ConfigValue Int64) instance NestedConfig Int64++-- | @since 0.0.1.0+deriving via (ConfigValue Integer) instance NestedConfig Integer++-- | @since 0.0.1.0+deriving via (ConfigValue Word) instance NestedConfig Word++-- | @since 0.0.1.0+deriving via (ConfigValue Word8) instance NestedConfig Word8++-- | @since 0.0.1.0+deriving via (ConfigValue Word16) instance NestedConfig Word16++-- | @since 0.0.1.0+deriving via (ConfigValue Word32) instance NestedConfig Word32++-- | @since 0.0.1.0+deriving via (ConfigValue Word64) instance NestedConfig Word64++-- | @since 0.0.1.0+deriving via (ConfigValue (a, b)) instance NestedConfig (a, b)
+ src/Cfg/Source/NestedConfig.hs view
@@ -0,0 +1,58 @@+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 _ = []
+ src/Cfg/Source/RootConfig.hs view
@@ -0,0 +1,37 @@+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
+ src/Tree/Append.hs view
@@ -0,0 +1,41 @@+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
+ test/Cfg/EnvSpec.hs view
@@ -0,0 +1,92 @@+module Cfg.EnvSpec where++import Cfg.Env (envSource)+import Control.Monad.Identity+import Data.Text (Text)+import Data.Tree (Tree (..))+import System.Environment (setEnv)+import Test.Hspec+import Tree.Append++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" []]+      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++  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"+      let+        tree :: Tree Text = Node "A" [Node "B" [], Node "C" [], Node "D" []]++      let+        expected =+          Node+            "A"+            [ Node "B" [Node "Functor" []]+            , Node "C" [Node "Applicative" []]+            , Node "D" [Node "Monad" []]+            ]+      result <- envSource tree+      result `shouldBe` expected
+ test/Cfg/ParserSpec.hs view
@@ -0,0 +1,56 @@+module Cfg.ParserSpec where++import Cfg.Deriving.ConfigRoot (ConfigRoot (..))+import Cfg.Deriving.ConfigValue+import Cfg.Deriving.SubConfig (SubConfig (..))+import Cfg.Parser+import Data.Text (Text)+import Data.Tree (Tree (..))+import GHC.Generics (Generic (..))+import Test.Hspec++data SumTypeConfig = Case1 | Case2+  deriving stock (Generic, Show, Eq)+  deriving (ValueParser) via (ConfigValue SumTypeConfig)+  deriving (NestedParser)++data SubTyCon = SubDataCon+  { subKey1 :: Text+  , subKey2 :: Int+  , subKey3 :: Maybe Bool+  }+  deriving (Generic, Show, Eq)+  deriving (NestedParser) via (SubConfig SubTyCon)++data RootTyCon a = RootDataCon+  { key1 :: SumTypeConfig+  , key2 :: SubTyCon+  , key3 :: Int+  , key4 :: a+  }+  deriving stock (Generic, Show, Eq)+  deriving (RootParser) via (ConfigRoot (RootTyCon a))++spec :: Spec+spec = do+  describe "toRootConfig" $ do+    it "should parse a type from the sample config" $ do+      let+        subConfig = SubDataCon "Hello World" 27 (Just True)+      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)
+ test/Cfg/SourceSpec.hs view
@@ -0,0 +1,85 @@+module Cfg.SourceSpec where++import Cfg.Deriving.ConfigRoot+import Cfg.Deriving.ConfigValue+import Cfg.Deriving.LabelModifier+import Cfg.Deriving.SubConfig+import Cfg.Source+import Data.Text (Text)+import Data.Tree (Tree (..))+import GHC.Generics (Generic (..))+import Test.Hspec++spec :: Spec+spec = do+  describe "toRootConfig" $ 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+    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++data SumTypeConfig = Case1 | Case2+  deriving stock (Generic, Show)+  deriving (NestedConfig) via ConfigValue SumTypeConfig++data SubTyCon = SubDataCon+  { subKey1 :: Text+  , subKey2 :: Int+  , subKey3 :: Maybe Bool+  }+  deriving (Generic, Show)+  deriving (NestedConfig) via (SubConfig SubTyCon)++data RootTyCon a = RootDataCon+  { key1 :: SumTypeConfig+  , key2 :: SubTyCon+  , key3 :: Int+  , key4 :: a+  }+  deriving stock (Generic, Show)+  deriving (RootConfig) via (ConfigRoot (RootTyCon a))++data SubTyConOpts = SubDataConOpts+  { subKeyOpts1 :: Text+  , subKeyOpts2 :: Int+  , subKeyOpts3 :: Maybe Bool+  }+  deriving (Generic, Show)+  deriving (NestedConfig) via (SubConfigOpts ToUpper SubTyCon)++data RootTyConOpts a = RootDataConOpts+  { keyOpts1 :: SumTypeConfig+  , keyOpts2 :: SubTyConOpts+  , keyOpts3 :: Int+  , keyOpts4 :: a+  }+  deriving stock (Generic, Show)+  deriving (RootConfig) via (ConfigRootOpts ToUpper ToLower (RootTyConOpts a))
+ test/Main.hs view
@@ -0,0 +1,22 @@+module Main where++import Data.Maybe (fromMaybe)+import Spec qualified+import System.Environment (lookupEnv)+import Test.Hspec (parallel)+import Test.Hspec.Core.Runner (Config (..))+import Test.Hspec.Formatters (specdoc)+import Test.Hspec.Runner as TR (defaultConfig, hspecWith)+import Text.Read (readMaybe)++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)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}