From d1446a8435a3cf06371eb6d4ebe25d6491612f4d Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 22 May 2024 00:04:30 +0200
Subject: a generic, multi-source config interface

---
 src/Conftrack/Source.hs | 46 ++++++++++++++++++++++++++++++++++++++++++++++
 src/Conftrack/Value.hs  | 38 ++++++++++++++++++++++++++++++++++++++
 2 files changed, 84 insertions(+)
 create mode 100644 src/Conftrack/Source.hs
 create mode 100644 src/Conftrack/Value.hs

(limited to 'src/Conftrack')

diff --git a/src/Conftrack/Source.hs b/src/Conftrack/Source.hs
new file mode 100644
index 0000000..df6f82c
--- /dev/null
+++ b/src/Conftrack/Source.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Conftrack.Source (ConfigSource(..), SomeSource(..), Trivial(..)) where
+
+import Conftrack.Value (Key, Value(..), ConfigError(..), Origin)
+
+import Control.Monad.State (get, modify, StateT (..), MonadState (..))
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Function ((&))
+import Data.Text (Text)
+import qualified Data.Text as T
+
+
+class ConfigSource s where
+  type ConfigState s
+  fetchValue :: Key ->  s -> StateT (ConfigState s) IO (Either ConfigError (Value, Text))
+  leftovers ::  s -> StateT (ConfigState s) IO (Maybe [Key])
+
+data SomeSource = forall source. ConfigSource source
+   => SomeSource (source, ConfigState source)
+
+
+newtype Trivial = Trivial (Map Key Value)
+
+instance ConfigSource Trivial where
+  type ConfigState Trivial = [Key]
+  fetchValue key (Trivial tree) = do
+    case M.lookup key tree of
+      Nothing -> pure $ Left NotPresent
+      Just val -> do
+        modify (key :)
+        pure $ Right (val, "Trivial source with keys "<> T.pack (show (M.keys tree)))
+
+  leftovers (Trivial tree) = do
+    used <- get
+
+    M.keys tree
+     & filter (`notElem` used)
+     & Just
+     & pure
diff --git a/src/Conftrack/Value.hs b/src/Conftrack/Value.hs
new file mode 100644
index 0000000..c5768cc
--- /dev/null
+++ b/src/Conftrack/Value.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Conftrack.Value (Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..)) where
+
+import Data.Text(Text)
+import Data.List.NonEmpty (NonEmpty)
+
+data Value =
+  ConfigText Text
+  | ConfigInteger Integer
+  | ConfigOther Text Text
+  deriving Show
+
+newtype Key = Key (NonEmpty Text)
+  deriving newtype (Eq, Ord, Show)
+
+data ConfigError =
+  ParseError
+  | NotPresent
+  deriving Show
+
+class ConfigValue a where
+  fromConfig :: Value -> Either ConfigError a
+
+data Origin = Origin Key Text
+  deriving Show
+
+instance ConfigValue Text where
+  fromConfig (ConfigText a) = Right a
+  fromConfig _ = Left ParseError
+
+instance ConfigValue Integer where
+  fromConfig (ConfigInteger a) = Right a
+  fromConfig _ = Left ParseError
-- 
cgit v1.2.3