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
|
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE OverloadedStrings #-}
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
| ConfigInteger Integer
| ConfigOther Text Text
| ConfigBool Bool
| ConfigNull
deriving Show
type KeyPart = Text
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))
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)
data ConfigError =
ParseError Text
| TypeMismatch Text Value
| NotPresent Key
| Shadowed
deriving Show
class ConfigValue a where
fromConfig :: Value -> Either ConfigError a
data Origin = Origin Key Text
deriving Show
instance ConfigValue Text where
fromConfig (ConfigString a) = Right (BS.decodeUtf8 a)
fromConfig val = Left (TypeMismatch "text" val)
instance ConfigValue Integer where
fromConfig (ConfigInteger a) = Right a
fromConfig val = Left (TypeMismatch "integer" val)
instance ConfigValue Int where
fromConfig (ConfigInteger a) = Right (fromInteger a)
fromConfig val = Left (TypeMismatch "integer" val)
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)
instance ConfigValue OsPath where
fromConfig (ConfigString text) = case encodeUtf (T.unpack (BS.decodeUtf8 text)) of
Right path -> Right path
Left err -> Left (ParseError (T.pack $ show err))
fromConfig val = Left (TypeMismatch "path" val)
instance ConfigValue LB.ByteString where
fromConfig (ConfigString strict) = Right (LB.fromStrict strict)
fromConfig val = Left (TypeMismatch "string" val)
instance ConfigValue BS.ByteString where
fromConfig (ConfigString string) = Right string
fromConfig val = Left (TypeMismatch "string" val)
|
