From 33bce0badbeb834cf8c584df56c424fe1c9bff7a Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 8 Jun 2024 00:22:17 +0200
Subject: quasi-quotes for config keys

---
 conftrack.cabal        |  1 +
 src/Conftrack.hs       |  3 ++-
 src/Conftrack/Value.hs | 22 ++++++++++++++++++++--
 test/Main.hs           |  6 ++++--
 4 files changed, 27 insertions(+), 5 deletions(-)

diff --git a/conftrack.cabal b/conftrack.cabal
index bf564f8..57be213 100644
--- a/conftrack.cabal
+++ b/conftrack.cabal
@@ -37,6 +37,7 @@ library
                     , scientific
                     , filepath >= 1.4.100
                     , file-io
+                    , template-haskell
     hs-source-dirs:   src
     default-language: GHC2021
 
diff --git a/src/Conftrack.hs b/src/Conftrack.hs
index ab830ff..6f030a6 100644
--- a/src/Conftrack.hs
+++ b/src/Conftrack.hs
@@ -22,9 +22,10 @@ module Conftrack
   , Key(..)
   , Value(..)
   , configKeysOf
+  , key
   ) where
 
-import Conftrack.Value (ConfigError(..), ConfigValue(..), Key (..), Origin(..), Value(..), KeyPart, prefixedWith)
+import Conftrack.Value (ConfigError(..), ConfigValue(..), Key (..), Origin(..), Value(..), KeyPart, prefixedWith, key)
 import Conftrack.Source (SomeSource (..), ConfigSource (..))
 
 import Prelude hiding (unzip)
diff --git a/src/Conftrack/Value.hs b/src/Conftrack/Value.hs
index 5c8d949..6fe8780 100644
--- a/src/Conftrack/Value.hs
+++ b/src/Conftrack/Value.hs
@@ -6,15 +6,18 @@
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Conftrack.Value (Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..), KeyPart, prefixedWith) where
+module Conftrack.Value (key, Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..), KeyPart, prefixedWith) where
 
 import Data.Text(Text)
 import qualified Data.Text as T
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LB
 import Data.List.NonEmpty (NonEmpty, prependList)
+import qualified Data.List.NonEmpty as NonEmpty
 import System.OsPath (OsPath, encodeUtf)
 import qualified Data.Text.Encoding as BS
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+import Language.Haskell.TH.Syntax (Lift(lift))
 
 data Value =
   ConfigString BS.ByteString
@@ -27,7 +30,22 @@ data Value =
 type KeyPart = Text
 
 newtype Key = Key (NonEmpty KeyPart)
-  deriving newtype (Eq, Ord, Show)
+  deriving newtype (Eq, Ord)
+  deriving (Lift)
+
+instance Show Key where
+  show (Key parts) = T.unpack (T.intercalate "." (NonEmpty.toList parts))
+
+key :: QuasiQuoter
+key = QuasiQuoter
+  { quoteExp = lift . Key . NonEmpty.fromList . T.splitOn "." . T.pack
+  , quotePat = \_ -> fail "key quoter cannot be used in patterns"
+  , quoteType = \_ -> fail "key quasi-quote cannot be used for types"
+  , quoteDec = \_ -> fail "key quasi-quote cannot be used in declarations"}
+
+blub :: String -> Key
+blub = undefined
+
 
 prefixedWith :: Key -> [KeyPart] -> Key
 prefixedWith (Key key) prefix = Key (prependList prefix key)
diff --git a/test/Main.hs b/test/Main.hs
index 1af3d9a..2b96ac9 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE QuasiQuotes #-}
 module Main (main) where
 
 import Conftrack
@@ -87,15 +88,16 @@ prop_aeson_nested = roundtripVia nestedToJson
 prop_flat_keys :: Property
 prop_flat_keys = monadicIO $ do
   keys <- run $ configKeysOf @TestFlat
-  assert (null (keys \\ [ Key ["foo"], Key ["bar"] ]))
+  assert (null (keys \\ [ [key|foo|], [key|bar|] ]))
 
 prop_nested_keys :: Property
 prop_nested_keys = monadicIO $ do
   keys <- run $ configKeysOf @TestNested
-  assert (null (keys \\ [ Key ["foo"], Key ["nested", "bar"], Key ["nested", "foo"] ]))
+  assert (null (keys \\ [ [key|foo|], [key|nested.bar|], [key|nested.foo|] ]))
 
 -- see quickcheck docs for why this return is here
 return []
+runTests :: IO Bool
 runTests = $quickCheckAll
 
 main :: IO ()
-- 
cgit v1.2.3