Skip to content

Commit 8a27f3e

Browse files
worm2fedworm2fed
committed
[LTB-61] Add ToJSON instance for config file
Problem: We have FromJSON instance so we can parse configuration from valid json or yaml. But there are cases when we want print this config file, send, log, etc. So it's useful to have ToJSON instance too. Solution: Add ToJSON instance for ConfigRec, converting to json happens with help of OptionsToJson class which recursively goes through config file and convert values. Note: we independently implemented `ToJSON` in this PR before we noticed #53
1 parent 18ced0d commit 8a27f3e

File tree

4 files changed

+173
-39
lines changed

4 files changed

+173
-39
lines changed

‎code/config/lib/Loot/Config/Yaml.hs

Lines changed: 78 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -2,26 +2,31 @@
22

33
{-# OPTIONS_GHC -fno-warn-orphans #-}
44

5+
{-# LANGUAGE AllowAmbiguousTypes #-}
56
{-# LANGUAGE DataKinds #-}
6-
{-# LANGUAGE KindSignatures #-}
7+
{-# LANGUAGE TypeFamilies #-}
78
{-# LANGUAGE TypeOperators #-}
89
{-# LANGUAGE UndecidableInstances #-}
9-
{-# LANGUAGE MonoLocalBinds #-}
1010

11-
-- | Utilities for reading configuration from a file.
11+
-- | Utilities for parsing and serializing configuration with Yaml/JSON.
1212
module Loot.Config.Yaml
1313
( configParser
1414
) where
1515

16-
import Data.Aeson (FromJSON (parseJSON))
16+
import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (Object))
1717
import Data.Aeson.BetterErrors (Parse, fromAesonParser, keyMay, keyOrDefault, toAesonParser')
18-
import Data.Vinyl (Rec ((:&), RNil))
18+
import Data.Aeson.Types (Object)
19+
import Data.Vinyl (Rec (RNil, (:&)))
1920
import GHC.TypeLits (KnownSymbol, symbolVal)
2021

21-
import Loot.Config.Record ((:::), (::<), (::+), (::-), ConfigKind (Partial),
22-
ConfigRec, Item (ItemOptionP, ItemSub, ItemSumP, ItemBranchP),
23-
ItemKind, SumSelection)
22+
import qualified Data.HashMap.Strict as HM
2423

24+
import Loot.Config.Record ((:::), (::<), (::+), (::-), ConfigKind (..),
25+
ConfigRec, Item (..), ItemKind, SumSelection)
26+
27+
-- | Helper function to get config key from type level
28+
getConfigKey :: forall l . KnownSymbol l => Text
29+
getConfigKey = fromString $ symbolVal (Proxy :: Proxy l)
2530

2631
-- | This class is almost like 'FromJSON' but uses @aeson-better-errors@.
2732
class OptionsFromJson (is :: [ItemKind]) where
@@ -41,7 +46,7 @@ instance
4146
configParser = (:&) <$> fmap ItemOptionP parseOption <*> configParser
4247
where
4348
parseOption :: Parse e (Maybe v)
44-
parseOption = keyMay (fromString $ symbolVal (Proxy :: Proxy l)) fromAesonParser
49+
parseOption = keyMay (getConfigKey @l) fromAesonParser
4550

4651
instance
4752
forall l us is.
@@ -53,7 +58,7 @@ instance
5358
=> OptionsFromJson ((l ::< us) ': is)
5459
where
5560
configParser = (:&)
56-
<$> fmap ItemSub (parseMulti (Proxy :: Proxy l))
61+
<$> fmap ItemSub (parseMulti @l)
5762
<*> configParser
5863

5964
instance
@@ -66,7 +71,7 @@ instance
6671
=> OptionsFromJson ((l ::+ us) ': is)
6772
where
6873
configParser = (:&)
69-
<$> fmap ItemSumP (parseMulti (Proxy :: Proxy l))
74+
<$> fmap ItemSumP (parseMulti @l)
7075
<*> configParser
7176

7277
instance
@@ -79,7 +84,7 @@ instance
7984
=> OptionsFromJson ((l ::- us) ': is)
8085
where
8186
configParser = (:&)
82-
<$> fmap ItemBranchP (parseMulti (Proxy :: Proxy l))
87+
<$> fmap ItemBranchP (parseMulti @l)
8388
<*> configParser
8489

8590
-- | Internal function to parse multiple 'Item's
@@ -89,9 +94,67 @@ parseMulti
8994
, Monoid (ConfigRec 'Partial us)
9095
, OptionsFromJson us
9196
)
92-
=> Proxy l
93-
-> Parse e (ConfigRec 'Partial us)
94-
parseMulti p = keyOrDefault (fromString $ symbolVal p) mempty configParser
97+
=> Parse e (ConfigRec 'Partial us)
98+
parseMulti = keyOrDefault (getConfigKey @l) mempty configParser
9599

96100
instance OptionsFromJson is => FromJSON (ConfigRec 'Partial is) where
97101
parseJSON = toAesonParser' configParser
102+
103+
-- Helper function to insert values in a JSON 'Object' by config key.
104+
insert' :: forall l v . (KnownSymbol l, ToJSON v) => v -> Object -> Object
105+
insert' value = HM.insert (getConfigKey @l) (toJSON value)
106+
107+
-- | This class is helper which converts config to object
108+
class OptionsToJson (k :: ConfigKind) (is :: [ItemKind]) where
109+
-- | Convert 'ConfigRec' to 'Object'
110+
configToObject :: ConfigRec k is -> Object
111+
112+
instance OptionsToJson (k :: ConfigKind) '[] where
113+
configToObject RNil = HM.empty
114+
115+
instance
116+
forall l v is k
117+
. ( KnownSymbol l
118+
, ToJSON v
119+
, OptionsToJson k is
120+
)
121+
=> OptionsToJson k ((l ::: v) ': is) where
122+
configToObject (ItemOptionP Nothing :& vs) = configToObject vs
123+
configToObject (ItemOptionP (Just v) :& vs) = insert' @l v $ configToObject vs
124+
configToObject (ItemOptionF v :& vs) = insert' @l v $ configToObject vs
125+
126+
instance
127+
forall l us is k
128+
. ( KnownSymbol l
129+
, Monoid (ConfigRec 'Partial us)
130+
, OptionsToJson k us
131+
, OptionsToJson k is
132+
)
133+
=> OptionsToJson k ((l ::< us) ': is) where
134+
configToObject (ItemSub v :& vs) = insert' @l v $ configToObject vs
135+
136+
instance
137+
forall l us is k
138+
. ( KnownSymbol l
139+
, Monoid (ConfigRec 'Partial (SumSelection l : us))
140+
, OptionsToJson k (SumSelection l : us)
141+
, OptionsToJson k is
142+
)
143+
=> OptionsToJson k ((l ::+ us) ': is) where
144+
configToObject (ItemSumP v :& vs) = insert' @l v $ configToObject vs
145+
configToObject (ItemSumF v :& vs) = insert' @l v $ configToObject vs
146+
147+
instance
148+
forall l us is k
149+
. ( KnownSymbol l
150+
, Monoid (ConfigRec 'Partial us)
151+
, OptionsToJson k us
152+
, OptionsToJson k is
153+
)
154+
=> OptionsToJson k ((l ::- us) ': is) where
155+
configToObject (ItemBranchP v :& vs) = insert' @l v $ configToObject vs
156+
configToObject (ItemBranchF Nothing :& vs) = configToObject vs
157+
configToObject (ItemBranchF (Just v) :& vs) = insert' @l v $ configToObject vs
158+
159+
instance OptionsToJson k is => ToJSON (ConfigRec k is) where
160+
toJSON = Object . configToObject

‎code/config/loot-config.cabal

Lines changed: 46 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,10 @@
11
cabal-version: 1.12
22

3-
-- This file has been generated from package.yaml by hpack version 0.33.0.
3+
-- This file has been generated from package.yaml by hpack version 0.34.4.
44
--
55
-- see: https://github.com/sol/hpack
66
--
7-
-- hash: 6ebb1bd44c4c2e80aacb126114954190d85eada672cfe689b45e287efaf555e5
7+
-- hash: 307894133adc515bce8125fc12e960451e00e29e69adc56ed0ccbcb45501cb75
88

99
name: loot-config
1010
version: 0.0.0.0
@@ -34,7 +34,27 @@ library
3434
Paths_loot_config
3535
hs-source-dirs:
3636
lib
37-
default-extensions: ApplicativeDo BangPatterns DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving LambdaCase MultiWayIf MultiParamTypeClasses NamedFieldPuns OverloadedLabels OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskell TupleSections TypeApplications ViewPatterns
37+
default-extensions:
38+
ApplicativeDo
39+
BangPatterns
40+
DeriveGeneric
41+
FlexibleContexts
42+
FlexibleInstances
43+
FunctionalDependencies
44+
GeneralizedNewtypeDeriving
45+
LambdaCase
46+
MultiWayIf
47+
MultiParamTypeClasses
48+
NamedFieldPuns
49+
OverloadedLabels
50+
OverloadedStrings
51+
RankNTypes
52+
RecordWildCards
53+
ScopedTypeVariables
54+
TemplateHaskell
55+
TupleSections
56+
TypeApplications
57+
ViewPatterns
3858
ghc-options: -Wall -hide-package base
3959
build-depends:
4060
aeson
@@ -45,6 +65,7 @@ library
4565
, loot-prelude
4666
, microlens
4767
, optparse-applicative
68+
, unordered-containers
4869
, validation
4970
, vinyl
5071
default-language: Haskell2010
@@ -57,7 +78,27 @@ test-suite loot-base-test
5778
Paths_loot_config
5879
hs-source-dirs:
5980
test
60-
default-extensions: ApplicativeDo BangPatterns DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving LambdaCase MultiWayIf MultiParamTypeClasses NamedFieldPuns OverloadedLabels OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskell TupleSections TypeApplications ViewPatterns
81+
default-extensions:
82+
ApplicativeDo
83+
BangPatterns
84+
DeriveGeneric
85+
FlexibleContexts
86+
FlexibleInstances
87+
FunctionalDependencies
88+
GeneralizedNewtypeDeriving
89+
LambdaCase
90+
MultiWayIf
91+
MultiParamTypeClasses
92+
NamedFieldPuns
93+
OverloadedLabels
94+
OverloadedStrings
95+
RankNTypes
96+
RecordWildCards
97+
ScopedTypeVariables
98+
TemplateHaskell
99+
TupleSections
100+
TypeApplications
101+
ViewPatterns
61102
ghc-options: -Wall -hide-package base -threaded -rtsopts -with-rtsopts=-N
62103
build-depends:
63104
aeson
@@ -71,4 +112,5 @@ test-suite loot-base-test
71112
, tasty-discover
72113
, tasty-hedgehog
73114
, tasty-hunit
115+
, text
74116
default-language: Haskell2010

‎code/config/package.yaml

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ library:
1212
- loot-base
1313
- microlens
1414
- optparse-applicative
15+
- unordered-containers
1516
- validation
1617
- vinyl
1718

@@ -30,4 +31,5 @@ tests:
3031
- tasty-hunit
3132

3233
- aeson
34+
- text
3335
- optparse-applicative

‎code/config/test/Test/Loot/Config.hs

Lines changed: 47 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -10,21 +10,25 @@
1010

1111
module Test.Loot.Config where
1212

13-
import Data.Aeson (FromJSON, eitherDecode)
13+
import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode)
1414
import Loot.Base.HasLens (lensOf)
1515
import Options.Applicative (Parser, auto, defaultPrefs, execParserPure, getParseResult, info, long)
16+
17+
import qualified Data.Text as T
1618
import qualified Options.Applicative as O
1719

1820
import Loot.Config
1921

20-
import Hedgehog (Property, forAll, property, (===))
22+
import Hedgehog (Gen, Property, forAll, property, (===))
2123
import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, (@=?))
2224

2325
import qualified Hedgehog.Gen as Gen
2426
import qualified Hedgehog.Range as Range
2527

26-
newtype SomeKek = SomeKek Integer deriving (Eq,Ord,Show,Read,Generic,FromJSON)
27-
newtype SomeMem = SomeMem String deriving (Eq,Ord,Show,IsString,Generic,FromJSON)
28+
newtype SomeKek = SomeKek Integer
29+
deriving (Eq, Ord, Show, Read, Generic, FromJSON, ToJSON)
30+
newtype SomeMem = SomeMem String
31+
deriving (Eq, Ord, Show, IsString, Generic, FromJSON, ToJSON)
2832

2933
type Fields = '[ "str" ::: String
3034
, "int" ::: Int
@@ -61,6 +65,29 @@ type Sub3Fields = '[ "int4" ::: Int ]
6165
cfg :: PartialConfig Fields
6266
cfg = mempty
6367

68+
cfgOptionPartial :: Gen (PartialConfig Fields)
69+
cfgOptionPartial = do
70+
-- note: we use text here because aeson does not handle control characters
71+
-- so for example in case of \55296 our test where we encode and then decode
72+
-- string will fail
73+
str <- Gen.text (Range.linear 0 10) Gen.enumBounded
74+
int <- Gen.int Range.constantBounded
75+
pure $ cfg
76+
& option #str ?~ T.unpack str
77+
& option #int ?~ int
78+
79+
fullConfig :: ConfigRec 'Partial Fields
80+
fullConfig =
81+
cfg & option #str ?~ "hey"
82+
& option #int ?~ 12345
83+
& option #kek ?~ SomeKek 999
84+
& sub #sub . option #bool ?~ False
85+
& sub #sub . option #int2 ?~ 13579
86+
& sub #sub . sub #sub2 . option #str2 ?~ ""
87+
& sub #sub . sub #sub2 . option #mem ?~ SomeMem "bye"
88+
& tree #tre . selection ?~ "brc1"
89+
& tree #tre . option #str3 ?~ "lemon"
90+
& tree #tre . branch #brc1 . option #int3 ?~ 54321
6491

6592
unit_emptyPartial :: Assertion
6693
unit_emptyPartial = do
@@ -71,7 +98,6 @@ unit_emptyPartial = do
7198
\brc2 =- {str4 <unset>, sub3 =< {int4 <unset>}}}}"
7299
s @=? show cfg
73100

74-
75101
unit_lensesEmptyPartial :: Assertion
76102
unit_lensesEmptyPartial = do
77103
cfg ^. option #str @=? Nothing
@@ -142,7 +168,6 @@ hprop_lensTreeOptionPartial = property $ do
142168
cfg3 ^. tree #tre . option #str3 === Just str
143169
cfg3 ^. tree #tre . branch #brc1 . option #int3 === Just int
144170

145-
146171
hprop_mappendPartial :: Property
147172
hprop_mappendPartial = property $ do
148173
str1 <- forAll $ Gen.string (Range.linear 0 10) Gen.enumBounded
@@ -248,6 +273,21 @@ unit_parseJsonTree3 =
248273
cfg & tree #tre . selection ?~ "brc1"
249274
& tree #tre . branch #brc1 . option #int3 ?~ 10
250275

276+
-- | Helper for testing JSON roundtrip.
277+
testRoundtrip :: PartialConfig Fields -> Assertion
278+
testRoundtrip config = Right config @=? (eitherDecode . encode) config
279+
280+
unit_jsonRoundtripEmptyPartial :: Assertion
281+
unit_jsonRoundtripEmptyPartial = testRoundtrip cfg
282+
283+
unit_jsonRoundtripFullConfig :: Assertion
284+
unit_jsonRoundtripFullConfig = testRoundtrip fullConfig
285+
286+
hprop_jsonRoundtripOptionPartial :: Property
287+
hprop_jsonRoundtripOptionPartial = property $ do
288+
config <- forAll cfgOptionPartial
289+
(eitherDecode . encode) config === Right config
290+
251291
-----------------------
252292
-- Finalisation
253293
-----------------------
@@ -282,19 +322,6 @@ unit_finaliseSome = do
282322
, "tre.brc1.int3"
283323
]
284324

285-
fullConfig :: ConfigRec 'Partial Fields
286-
fullConfig =
287-
cfg & option #str ?~ "hey"
288-
& option #int ?~ 12345
289-
& option #kek ?~ (SomeKek 999)
290-
& sub #sub . option #bool ?~ False
291-
& sub #sub . option #int2 ?~ 13579
292-
& sub #sub . sub #sub2 . option #str2 ?~ ""
293-
& sub #sub . sub #sub2 . option #mem ?~ (SomeMem "bye")
294-
& tree #tre . selection ?~ "brc1"
295-
& tree #tre . option #str3 ?~ "lemon"
296-
& tree #tre . branch #brc1 . option #int3 ?~ 54321
297-
298325
unit_finalise :: Assertion
299326
unit_finalise = do
300327
let cfg1 = fullConfig
@@ -341,7 +368,7 @@ fieldsParser =
341368
#mem .:: (O.strOption $ long "mem"))
342369
) <*<
343370
#kek .:: (O.option auto $ long "kek") <*<
344-
#tre .:+
371+
#tre .:+
345372
(#treType .:: (O.strOption $ long "treType") <*<
346373
#str3 .:: (O.strOption $ long "str3") <*<
347374
#brc1 .:-

0 commit comments

Comments
 (0)