summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--conftrack.cabal1
-rw-r--r--src/Conftrack.hs3
-rw-r--r--src/Conftrack/Value.hs22
-rw-r--r--test/Main.hs6
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 ()