1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DefaultSignatures #-}
module Conftrack.Value (key, Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..), KeyPart, prefixedWith, withString) 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))
-- | A generic value read from a config source, to be parsed into a more useful type
-- (see the 'ConfigValue' class).
data Value =
ConfigString BS.ByteString
| ConfigInteger Integer
-- | A value which may be an integer, but the source cannot say for sure, e.g. because
-- its values are entirely untyped. Use 'withString' to handle such cases.
| ConfigMaybeInteger BS.ByteString Integer
| ConfigOther Text Text
| ConfigBool Bool
| ConfigNull
deriving Show
type KeyPart = Text
-- | A configuration key is a non-empty list of parts. By convention, these parts
-- are separated by dots when written, although dots withing parts are not disallowed.
--
-- For writing values easily, consider enabling the @QuasiQuotes@ language extension
-- to use 'key':
--
-- >>> [key|foo.bar|]
-- foo.bar
newtype Key = Key (NonEmpty KeyPart)
deriving newtype (Eq, Ord)
deriving (Lift)
instance Show Key where
show (Key parts) = T.unpack (T.intercalate "." (NonEmpty.toList parts))
-- | to write values of 'Key' easily
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"}
prefixedWith :: Key -> [KeyPart] -> Key
prefixedWith (Key k) prefix = Key (prependList prefix k)
data ConfigError =
ParseError Text
| TypeMismatch Text Value
| NotPresent Key
| Shadowed
deriving Show
-- | Values which can be read from a config source must implement this class
class ConfigValue a where
fromConfig :: Value -> Either ConfigError a
-- | optionally, a function to pretty-print values of this type, used by the
-- functions of "Conftrack.Pretty". If not given, defaults to @a@'s 'Show' instance.
prettyValue :: a -> Text
default prettyValue :: Show a => a -> Text
prettyValue = T.pack . show
data Origin = forall a. ConfigValue a => Origin a Text
instance Show Origin where
show (Origin a text) = "Origin " <> T.unpack (prettyValue a) <> " " <> T.unpack text
withString :: (BS.ByteString -> Either ConfigError a) -> Value -> Either ConfigError a
withString f (ConfigString a) = f a
withString f (ConfigMaybeInteger a _) = f a
withString _ val = Left (TypeMismatch "text" val)
withInteger :: (Integer -> Either ConfigError a) -> Value -> Either ConfigError a
withInteger f (ConfigInteger a) = f a
withInteger f (ConfigMaybeInteger _ a) = f a
withInteger _ val = Left (TypeMismatch "integer" val)
instance ConfigValue Text where
fromConfig = withString (Right . BS.decodeUtf8)
instance ConfigValue Integer where
fromConfig = withInteger Right
instance ConfigValue Int where
fromConfig = withInteger (Right . fromInteger)
instance ConfigValue Bool where
fromConfig (ConfigBool b) = Right b
fromConfig val = Left (TypeMismatch "bool" val)
instance ConfigValue a => ConfigValue (Maybe a) where
fromConfig ConfigNull = Right Nothing
fromConfig just = fmap Just (fromConfig just)
prettyValue Nothing = "null"
prettyValue (Just a) = prettyValue a
instance ConfigValue OsPath where
fromConfig = \case
(ConfigString text) -> stringToPath text
(ConfigMaybeInteger text _) -> stringToPath text
val -> Left (TypeMismatch "path" val)
where stringToPath text = case encodeUtf (T.unpack (BS.decodeUtf8 text)) of
Right path -> Right path
Left err -> Left (ParseError (T.pack $ show err))
instance ConfigValue LB.ByteString where
fromConfig = withString (Right . LB.fromStrict)
instance ConfigValue BS.ByteString where
fromConfig = withString Right
|
