Merge pull request #56 from serokell/worm2fed/ltb-65-buildable-for-configrec

[LTB-65] Add Buildable for ConfigRec

Author: worm2fed

.stylish-haskell.yaml

@@ -0,0 +1,55 @@
+# SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io>
+#
+# SPDX-License-Identifier: Unlicense
+
+steps:
+  - simple_align:
+      cases: false
+      top_level_patterns: false
+      records: false
+  - imports:
+      align: none
+      list_align: after_alias
+      pad_module_names: false
+      long_list_align: inline
+      empty_list_align: inherit
+      list_padding: 2
+      separate_lists: true
+      space_surround: false
+  - trailing_whitespace: {}
+columns: 80
+newline: native
+language_extensions:
+  - BangPatterns
+  - ConstraintKinds
+  - DataKinds
+  - DefaultSignatures
+  - DeriveDataTypeable
+  - DeriveGeneric
+  - DerivingStrategies
+  - EmptyCase
+  - ExistentialQuantification
+  - ExplicitNamespaces
+  - FlexibleContexts
+  - FlexibleInstances
+  - FunctionalDependencies
+  - GADTs
+  - GeneralizedNewtypeDeriving
+  - LambdaCase
+  - MultiParamTypeClasses
+  - MultiWayIf
+  - NamedFieldPuns
+  - NoImplicitPrelude
+  - OverloadedLabels
+  - OverloadedStrings
+  - PatternSynonyms
+  - RecordWildCards
+  - RecursiveDo
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - TemplateHaskell
+  - TupleSections
+  - TypeApplications
+  - TypeFamilies
+  - TypeOperators
+  - ViewPatterns

code/config/lib/Loot/Config.hs

@@ -1,32 +1,31 @@
 {- SPDX-License-Identifier: MPL-2.0 -}
 
 {-# LANGUAGE DataKinds     #-}
-{-# LANGUAGE TypeOperators #-}
 
 -- | Flexible and convenient configuration framework.
 module Loot.Config
-       ( module Loot.Config.Record
-       , module Loot.Config.Generics
-       , module Loot.Config.Lens
-       , module Loot.Config.CLI
+  ( module Loot.Config.Record
+  , module Loot.Config.Generics
+  , module Loot.Config.Lens
+  , module Loot.Config.CLI
 
-       , Config
-       , PartialConfig
+  , Config
+  , PartialConfig
 
-       , module Lens.Micro
-       ) where
+  , module Lens.Micro
+  ) where
 
 import Lens.Micro ((?~))
 
+import Loot.Config.Buildable ()
 import Loot.Config.CLI
 import Loot.Config.Generics
 import Loot.Config.Lens
-import Loot.Config.Record ((::+), (::-), (:::), (::<), ConfigKind (Final, Partial), ConfigRec,
-                           branch, complement, finalise, finaliseDeferredUnsafe, option, selection,
-                           sub, tree, upcast)
+import Loot.Config.Record (ConfigKind (..), ConfigRec, branch, complement,
+                           finalise, finaliseDeferredUnsafe, option, selection,
+                           sub, tree, upcast, (::+), (::-), (:::), (::<))
 import Loot.Config.Yaml ()
 
-
 type Config = ConfigRec 'Final
 
 type PartialConfig = ConfigRec 'Partial

code/config/lib/Loot/Config/Buildable.hs

@@ -0,0 +1,85 @@
+{- SPDX-License-Identifier: MPL-2.0 -}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE KindSignatures       #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GADTs #-}
+
+module Loot.Config.Buildable
+  (
+  ) where
+
+import Data.Vinyl (Rec (RNil, (:&)))
+import Fmt (Buildable (..), Builder, blockMapF)
+import GHC.TypeLits (KnownSymbol)
+
+import Loot.Config.Record (ConfigKind, ConfigRec, Item (..), ItemKind,
+                           SumSelection, getConfigKey, (::+), (::-), (:::),
+                           (::<))
+
+class OptionsToBuilderList (k :: ConfigKind) (is :: [ItemKind]) where
+  configToBuilderList :: ConfigRec k is -> [(Text, Builder)]
+
+instance OptionsToBuilderList (k :: ConfigKind) '[] where
+  configToBuilderList RNil = []
+
+undefinedBuilder :: Builder
+undefinedBuilder = build @Text "<undefined>"
+
+instance
+  ( KnownSymbol l
+  , Buildable v
+  , OptionsToBuilderList k is
+  ) => OptionsToBuilderList k ((l ::: v) ': is)
+  where
+    configToBuilderList (itemOption :& rest) =
+      let label = getConfigKey @l
+          value = case itemOption of
+            ItemOptionP (Just v) -> build v
+            ItemOptionP Nothing -> undefinedBuilder
+            ItemOptionF v -> build v
+      in (label, value) : configToBuilderList @k @is rest
+
+instance
+  ( KnownSymbol l
+  , OptionsToBuilderList k us
+  , OptionsToBuilderList k is
+  ) => OptionsToBuilderList k ((l ::< us) ': is)
+  where
+    configToBuilderList (ItemSub inner :& rest) =
+      let label = getConfigKey @l
+          value = blockMapF $ configToBuilderList inner
+      in (label, value) : configToBuilderList rest
+
+instance
+  ( KnownSymbol l
+  , OptionsToBuilderList k  (SumSelection l : us)
+  , OptionsToBuilderList k is
+  ) => OptionsToBuilderList k ((l ::+ us) ': is)
+  where
+    configToBuilderList (itemSum :& rest) =
+      let label = getConfigKey @l
+          value = case itemSum of
+            ItemSumP inner -> blockMapF $ configToBuilderList inner
+            ItemSumF inner -> blockMapF $ configToBuilderList inner
+      in (label, value) : configToBuilderList rest
+
+instance
+  ( KnownSymbol l
+  , OptionsToBuilderList k us
+  , OptionsToBuilderList k is
+  ) => OptionsToBuilderList k ((l ::- us) ': is)
+  where
+    configToBuilderList (itemBranch :& rest) =
+      let label = getConfigKey @l
+          value = case itemBranch of
+            ItemBranchP inner -> blockMapF $ configToBuilderList inner
+            ItemBranchF (Just inner) -> blockMapF $ configToBuilderList inner
+            ItemBranchF Nothing -> undefinedBuilder
+      in (label, value) : configToBuilderList rest
+
+instance OptionsToBuilderList k is => Buildable (ConfigRec k is) where
+  build config = blockMapF $ configToBuilderList config

code/config/lib/Loot/Config/CLI.hs

@@ -6,26 +6,27 @@
 
 -- | Utilities for reading configuration from command-line parameters.
 module Loot.Config.CLI
-       ( ModParser
-       , OptModParser
-       , modifying
-       , uplift
-       , (..:)
-       , (.%:)
-       , (<*<)
-       , (.::)
-       , (%::)
-       , (.:<)
-       , (.:+)
-       , (.:-)
-       ) where
-
-import Data.Vinyl (Label, type (<:), rreplace, rcast)
+  ( ModParser
+  , OptModParser
+  , modifying
+  , uplift
+  , (..:)
+  , (.%:)
+  , (<*<)
+  , (.::)
+  , (%::)
+  , (.:<)
+  , (.:+)
+  , (.:-)
+  ) where
+
+import Data.Vinyl (Label, rcast, rreplace, type (<:))
 import Lens.Micro (ASetter')
 import Options.Applicative (Parser, optional)
 
-import Loot.Config.Record (ConfigKind (Partial), ConfigRec, HasOption, HasSub,
-                           HasSum, HasBranch, SumSelection, option, sub, tree, branch)
+import Loot.Config.Record (ConfigKind (..), ConfigRec, HasBranch, HasOption,
+                           HasSub, HasSum, SumSelection, branch, option, sub,
+                           tree)
 
 -- | Type for a parser which yields a modifier function instead of a
 -- value
@@ -92,56 +93,56 @@ type OptModParser cfg = ModParser (ConfigRec 'Partial cfg)
 -- | Combinator which declares a config parser which parses one config
 -- option, leaving other options empty.
 (.::)
-    :: forall l is v. HasOption l is v
-    => Label l
-    -> Parser v
-    -> OptModParser is
+  :: forall l is v. HasOption l is v
+  => Label l
+  -> Parser v
+  -> OptModParser is
 l .:: p = (\mv -> option l %~ (mv <|>)) <$> optional p
 infixr 6 .::
 
 -- | Combinator which declares a config parser which modifies one config
 -- option, not touching other options.
 (%::)
-    :: forall l is v. HasOption l is v
-    => Label l
-    -> ModParser v
-    -> OptModParser is
+  :: forall l is v. HasOption l is v
+  => Label l
+  -> ModParser v
+  -> OptModParser is
 l %:: p = (\mf -> option l %~ fmap (fromMaybe id mf)) <$> optional p
 infixr 6 %::
 
 -- | Combinator which declares a config parser which parses one
 -- subsection, leaving other options empty.
 (.:<)
-    :: forall l is us. (HasSub l is us)
-    => Label l
-    -> OptModParser us
-    -> OptModParser is
+  :: forall l is us. (HasSub l is us)
+  => Label l
+  -> OptModParser us
+  -> OptModParser is
 l .:< p = (\uf cfg -> cfg & sub l %~ uf) <$> p
 infixr 6 .:<
 
 -- | Combinator which declares a config parser which parses one
 -- tree, leaving other options empty.
 (.:+)
-    :: forall l is us ms. (HasSum l is ms, us ~ (SumSelection l : ms))
-    => Label l
-    -> OptModParser us
-    -> OptModParser is
+  :: forall l is us ms. (HasSum l is ms, us ~ (SumSelection l : ms))
+  => Label l
+  -> OptModParser us
+  -> OptModParser is
 l .:+ p = (\uf cfg -> cfg & tree l %~ uf) <$> p
 infixr 6 .:+
 
 -- | Combinator which declares a config parser which parses one
 -- branch, leaving other options empty.
 (.:-)
-    :: forall l is us. (HasBranch l is us)
-    => Label l
-    -> OptModParser us
-    -> OptModParser is
+  :: forall l is us. (HasBranch l is us)
+  => Label l
+  -> OptModParser us
+  -> OptModParser is
 l .:- p = (\uf cfg -> cfg & branch l %~ uf) <$> p
 infixr 6 .:-
 
 -- | Lifts the modifier of a subconfig to a modifier of larger config.
 uplift
-    :: forall is us. (is <: us)
-    => OptModParser is
-    -> OptModParser us
+  :: forall is us. (is <: us)
+  => OptModParser is
+  -> OptModParser us
 uplift = fmap $ \f cfg -> rreplace (f $ rcast cfg) cfg