diff --git a/cfg.cabal b/cfg.cabal --- a/cfg.cabal +++ b/cfg.cabal @@ -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 diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/doctest/Main.hs @@ -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" + ] diff --git a/src/Cfg.hs b/src/Cfg.hs --- a/src/Cfg.hs +++ b/src/Cfg.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 + ) diff --git a/src/Cfg/Deriving.hs b/src/Cfg/Deriving.hs --- a/src/Cfg/Deriving.hs +++ b/src/Cfg/Deriving.hs @@ -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 diff --git a/src/Cfg/Deriving/Assert.hs b/src/Cfg/Deriving/Assert.hs --- a/src/Cfg/Deriving/Assert.hs +++ b/src/Cfg/Deriving/Assert.hs @@ -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." + ) + ) diff --git a/src/Cfg/Deriving/Config.hs b/src/Cfg/Deriving/Config.hs new file mode 100644 --- /dev/null +++ b/src/Cfg/Deriving/Config.hs @@ -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 diff --git a/src/Cfg/Deriving/ConfigRoot.hs b/src/Cfg/Deriving/ConfigRoot.hs deleted file mode 100644 --- a/src/Cfg/Deriving/ConfigRoot.hs +++ /dev/null @@ -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 diff --git a/src/Cfg/Deriving/ConfigValue.hs b/src/Cfg/Deriving/ConfigValue.hs deleted file mode 100644 --- a/src/Cfg/Deriving/ConfigValue.hs +++ /dev/null @@ -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) diff --git a/src/Cfg/Deriving/KeyModifier.hs b/src/Cfg/Deriving/KeyModifier.hs new file mode 100644 --- /dev/null +++ b/src/Cfg/Deriving/KeyModifier.hs @@ -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 diff --git a/src/Cfg/Deriving/LabelModifier.hs b/src/Cfg/Deriving/LabelModifier.hs deleted file mode 100644 --- a/src/Cfg/Deriving/LabelModifier.hs +++ /dev/null @@ -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 diff --git a/src/Cfg/Deriving/SubConfig.hs b/src/Cfg/Deriving/SubConfig.hs deleted file mode 100644 --- a/src/Cfg/Deriving/SubConfig.hs +++ /dev/null @@ -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 diff --git a/src/Cfg/Deriving/Value.hs b/src/Cfg/Deriving/Value.hs new file mode 100644 --- /dev/null +++ b/src/Cfg/Deriving/Value.hs @@ -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) diff --git a/src/Cfg/Env.hs b/src/Cfg/Env.hs --- a/src/Cfg/Env.hs +++ b/src/Cfg/Env.hs @@ -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 diff --git a/src/Cfg/Env/Keys.hs b/src/Cfg/Env/Keys.hs --- a/src/Cfg/Env/Keys.hs +++ b/src/Cfg/Env/Keys.hs @@ -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) diff --git a/src/Cfg/Options.hs b/src/Cfg/Options.hs --- a/src/Cfg/Options.hs +++ b/src/Cfg/Options.hs @@ -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 diff --git a/src/Cfg/Parser.hs b/src/Cfg/Parser.hs --- a/src/Cfg/Parser.hs +++ b/src/Cfg/Parser.hs @@ -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) diff --git a/src/Cfg/Parser/Config.hs b/src/Cfg/Parser/Config.hs new file mode 100644 --- /dev/null +++ b/src/Cfg/Parser/Config.hs @@ -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 diff --git a/src/Cfg/Parser/ConfigParser.hs b/src/Cfg/Parser/ConfigParser.hs deleted file mode 100644 --- a/src/Cfg/Parser/ConfigParser.hs +++ /dev/null @@ -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 diff --git a/src/Cfg/Parser/Value.hs b/src/Cfg/Parser/Value.hs new file mode 100644 --- /dev/null +++ b/src/Cfg/Parser/Value.hs @@ -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) diff --git a/src/Cfg/Parser/ValueParser.hs b/src/Cfg/Parser/ValueParser.hs deleted file mode 100644 --- a/src/Cfg/Parser/ValueParser.hs +++ /dev/null @@ -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) diff --git a/src/Cfg/Source.hs b/src/Cfg/Source.hs --- a/src/Cfg/Source.hs +++ b/src/Cfg/Source.hs @@ -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) diff --git a/src/Cfg/Source/Config.hs b/src/Cfg/Source/Config.hs new file mode 100644 --- /dev/null +++ b/src/Cfg/Source/Config.hs @@ -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 diff --git a/src/Cfg/Source/Default.hs b/src/Cfg/Source/Default.hs new file mode 100644 --- /dev/null +++ b/src/Cfg/Source/Default.hs @@ -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 diff --git a/src/Cfg/Source/NestedConfig.hs b/src/Cfg/Source/NestedConfig.hs deleted file mode 100644 --- a/src/Cfg/Source/NestedConfig.hs +++ /dev/null @@ -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 _ = [] diff --git a/src/Cfg/Source/RootConfig.hs b/src/Cfg/Source/RootConfig.hs deleted file mode 100644 --- a/src/Cfg/Source/RootConfig.hs +++ /dev/null @@ -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 diff --git a/src/KeyTree.hs b/src/KeyTree.hs new file mode 100644 --- /dev/null +++ b/src/KeyTree.hs @@ -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 diff --git a/src/Tree/Append.hs b/src/Tree/Append.hs deleted file mode 100644 --- a/src/Tree/Append.hs +++ /dev/null @@ -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 diff --git a/test/Cfg/Deriving/KeyModifierSpec.hs b/test/Cfg/Deriving/KeyModifierSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cfg/Deriving/KeyModifierSpec.hs @@ -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" diff --git a/test/Cfg/Env/KeysSpec.hs b/test/Cfg/Env/KeysSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cfg/Env/KeysSpec.hs @@ -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)) diff --git a/test/Cfg/EnvSpec.hs b/test/Cfg/EnvSpec.hs --- a/test/Cfg/EnvSpec.hs +++ b/test/Cfg/EnvSpec.hs @@ -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 diff --git a/test/Cfg/ParserSpec.hs b/test/Cfg/ParserSpec.hs --- a/test/Cfg/ParserSpec.hs +++ b/test/Cfg/ParserSpec.hs @@ -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) diff --git a/test/Cfg/SourceSpec.hs b/test/Cfg/SourceSpec.hs --- a/test/Cfg/SourceSpec.hs +++ b/test/Cfg/SourceSpec.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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)