ToJSON for Syntax
This commit is contained in:
Dmitry Zuikov
parent
0ee3ef62e8
commit
ae1449767f
|
|
@ -9,6 +9,9 @@ import Data.Config.Suckless.Parse
|
|||
import Data.String (IsString(..))
|
||||
import Data.Set qualified as Set
|
||||
import Data.Set (Set)
|
||||
import Data.Maybe
|
||||
import Data.Scientific
|
||||
import Data.Aeson
|
||||
import Prettyprinter
|
||||
import Safe
|
||||
|
||||
|
|
@ -27,6 +30,36 @@ class Monad m => HasConf m where
|
|||
pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]
|
||||
pattern Key n ns <- SymbolVal n : ns
|
||||
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Integer) m) => HasCfgValue a (Maybe Integer) m where
|
||||
cfgValue = lastMay . val <$> getConf
|
||||
where
|
||||
val syn = [ e
|
||||
| ListVal @C (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Integer) @m
|
||||
]
|
||||
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Scientific) m) => HasCfgValue a (Maybe Scientific) m where
|
||||
cfgValue = lastMay . val <$> getConf
|
||||
where
|
||||
val syn = [ e
|
||||
| ListVal @C (Key s [LitScientificVal e]) <- syn, s == key @a @(Maybe Scientific) @m
|
||||
]
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Bool) m) => HasCfgValue a (Maybe Bool) m where
|
||||
cfgValue = lastMay . val <$> getConf
|
||||
where
|
||||
val syn = [ e
|
||||
| ListVal @C (Key s [LitBoolVal e]) <- syn, s == key @a @(Maybe Bool) @m
|
||||
]
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Value) m) => HasCfgValue a (Maybe Value) m where
|
||||
cfgValue = lastMay . val <$> getConf
|
||||
where
|
||||
val syn = [ toJSON v
|
||||
| ListVal @C (Key s [v@ListVal{}]) <- syn, s == key @a @(Maybe Value) @m
|
||||
]
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Maybe b) m) => HasCfgValue a (Maybe b) m where
|
||||
cfgValue = lastMay . val <$> getConf
|
||||
where
|
||||
|
|
@ -34,9 +67,35 @@ instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Maybe
|
|||
| ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Maybe b) @m
|
||||
]
|
||||
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Integer) m) => HasCfgValue a (Set Integer) m where
|
||||
cfgValue = Set.fromList . val <$> getConf
|
||||
where
|
||||
val syn = [ e
|
||||
| ListVal @C (Key s [LitIntVal e]) <- syn, s == key @a @(Set Integer) @m
|
||||
]
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Scientific) m) => HasCfgValue a (Set Scientific) m where
|
||||
cfgValue = Set.fromList . val <$> getConf
|
||||
where
|
||||
val syn = [ e
|
||||
| ListVal @C (Key s [LitScientificVal e]) <- syn, s == key @a @(Set Scientific) @m
|
||||
]
|
||||
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Value) m) => HasCfgValue a (Set Value) m where
|
||||
cfgValue = Set.fromList . val <$> getConf
|
||||
where
|
||||
val syn = [ toJSON v
|
||||
| ListVal @C (Key s [v@ListVal{}]) <- syn, s == key @a @(Set Value) @m
|
||||
]
|
||||
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Set b) m) => HasCfgValue a (Set b) m where
|
||||
cfgValue = Set.fromList . val <$> getConf
|
||||
where
|
||||
val syn = [ fromString (show $ pretty e)
|
||||
| ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Set b) @m
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -15,13 +15,16 @@ import Control.Applicative()
|
|||
import Data.Text qualified as Text
|
||||
|
||||
import Control.Monad
|
||||
import Data.Functor
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char (hspace1,space1,char,letterChar,digitChar,eol)
|
||||
import Text.Megaparsec.Char (hspace1,space1,char,letterChar,digitChar,eol,string)
|
||||
import Text.Megaparsec.Char.Lexer qualified as L
|
||||
import Text.Megaparsec.Char.Lexer ( signed )
|
||||
import Data.String(IsString(..))
|
||||
import GHC.Generics
|
||||
import Data.Data
|
||||
import Safe
|
||||
import Data.Scientific
|
||||
|
||||
data MegaParsec =
|
||||
MegaParsec
|
||||
|
|
@ -72,19 +75,39 @@ stringLit sp = L.lexeme sp $ do
|
|||
s <- dquot >> manyTill L.charLiteral dquot
|
||||
pure $ Text.pack s -- (mconcat [ showLitChar c "" | c <- s ])
|
||||
|
||||
-- FIXME: position!
|
||||
intLit :: forall c . MegaConstraints c
|
||||
numLit :: forall c . MegaConstraints c
|
||||
=> Parser () -> Parser (Syntax c)
|
||||
|
||||
intLit sp = L.lexeme sp $ do
|
||||
numLit sp = L.lexeme sp $ do
|
||||
co <- MegaContext . Just <$> getOffset
|
||||
Literal co . LitInt <$> choice [hex, oct, bin, dec, dec']
|
||||
|
||||
s <- try (char '-' >> pure True) <|> pure False
|
||||
|
||||
base <- choice [ string "0x" >> pure 16
|
||||
, string "0o" >> pure 8
|
||||
, string "0b" >> pure 2
|
||||
, pure (10 :: Int)
|
||||
]
|
||||
|
||||
val <- case base of
|
||||
16 -> LitInt . sign s <$> L.hexadecimal
|
||||
8 -> LitInt . sign s <$> L.octal
|
||||
2 -> LitInt . sign s <$> L.binary
|
||||
10 -> do
|
||||
ns <- many (digitChar <|> oneOf ['.', 'e', '-'])
|
||||
let v = (LitInt . sign s <$> readMay @Integer ns)
|
||||
<|> (LitScientific . sign s <$> readMay @Scientific ns)
|
||||
case v of
|
||||
Just x -> pure x
|
||||
Nothing -> fail "not a numeric literal"
|
||||
|
||||
_ -> fail "not a numeric literal"
|
||||
|
||||
pure $ Literal co val
|
||||
|
||||
where
|
||||
hex = L.symbol sc "0x" >> L.hexadecimal
|
||||
oct = L.symbol sc "0o" >> L.octal
|
||||
bin = L.symbol sc "0b" >> L.binary
|
||||
dec = L.decimal
|
||||
dec'= signed sc L.decimal
|
||||
sign :: forall a . Num a => Bool -> a -> a
|
||||
sign x = if x then negate else id
|
||||
|
||||
symbolChars :: [Char]
|
||||
symbolChars = "-!$%&|*+/:<=>?@^_~#.'"
|
||||
|
|
@ -95,7 +118,7 @@ symbolChar = oneOf symbolChars
|
|||
symbolCharNoMinus :: Parser Char
|
||||
symbolCharNoMinus = oneOf symbolChars'
|
||||
where
|
||||
symbolChars' = dropWhile (== '-') symbolChars
|
||||
symbolChars' = dropWhile (`elem` "-") symbolChars
|
||||
|
||||
-- FIXME: position!
|
||||
symbol :: forall c . MegaConstraints c
|
||||
|
|
@ -152,9 +175,10 @@ list sp = L.lexeme sp $ do
|
|||
|
||||
syntax :: forall c . MegaConstraints c
|
||||
=> Parser () -> Parser (Syntax c)
|
||||
|
||||
syntax sp = choice [ symbol sp
|
||||
, numLit sp
|
||||
, stringLit sp
|
||||
, intLit sp
|
||||
, list sp
|
||||
]
|
||||
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ module Data.Config.Suckless.Syntax
|
|||
, pattern LitIntVal
|
||||
, pattern LitStrVal
|
||||
, pattern LitBoolVal
|
||||
, pattern LitScientificVal
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -22,7 +23,12 @@ import Data.Data
|
|||
import Data.Kind
|
||||
import Data.String
|
||||
import Data.Text (Text)
|
||||
import Data.Scientific
|
||||
import GHC.Generics
|
||||
import Data.Maybe
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Key
|
||||
import qualified Data.Vector as V
|
||||
|
||||
import Prettyprinter
|
||||
|
||||
|
|
@ -33,6 +39,9 @@ pattern SymbolVal v <- Symbol _ v
|
|||
pattern LitIntVal :: forall {c}. Integer -> Syntax c
|
||||
pattern LitIntVal v <- Literal _ (LitInt v)
|
||||
|
||||
pattern LitScientificVal :: forall {c}. Scientific -> Syntax c
|
||||
pattern LitScientificVal v <- Literal _ (LitScientific v)
|
||||
|
||||
pattern LitStrVal :: forall {c}. Text -> Syntax c
|
||||
pattern LitStrVal v <- Literal _ (LitStr v)
|
||||
|
||||
|
|
@ -63,6 +72,7 @@ newtype Id =
|
|||
data Literal =
|
||||
LitStr Text
|
||||
| LitInt Integer
|
||||
| LitScientific Scientific
|
||||
| LitBool Bool
|
||||
deriving stock (Eq,Ord,Data,Generic,Show)
|
||||
|
||||
|
|
@ -104,6 +114,7 @@ instance Pretty Literal where
|
|||
pretty = \case
|
||||
LitStr s -> dquotes (pretty s)
|
||||
LitInt i -> pretty i
|
||||
LitScientific v -> viaShow v
|
||||
|
||||
LitBool b | b -> "#t"
|
||||
| otherwise -> "#f"
|
||||
|
|
@ -115,3 +126,28 @@ deriving instance ( Data c
|
|||
) => Data (Syntax c)
|
||||
|
||||
|
||||
|
||||
instance ToJSON Literal where
|
||||
toJSON (LitStr s) = String s
|
||||
toJSON (LitInt i) = Number (fromInteger i)
|
||||
toJSON (LitScientific s) = Number s
|
||||
toJSON (LitBool b) = Bool b
|
||||
|
||||
instance ToJSON (Syntax c) where
|
||||
toJSON (Symbol _ (Id "#nil")) = Null
|
||||
toJSON (Symbol _ (Id s)) = String s
|
||||
toJSON (Literal _ l) = toJSON l
|
||||
toJSON (List _ items) =
|
||||
case items of
|
||||
(Symbol _ "object" : rest) ->
|
||||
object $ mapMaybe pairToKeyValue rest
|
||||
_ -> Array . V.fromList $ fmap toJSON items
|
||||
|
||||
where
|
||||
pairToKeyValue :: Syntax c -> Maybe (Key, Value)
|
||||
pairToKeyValue (List _ [SymbolVal (Id k), SymbolVal ":", v]) = Just (fromText k .= toJSON v)
|
||||
pairToKeyValue (List _ [LitStrVal k, SymbolVal ":", v]) = Just (fromText k .= toJSON v)
|
||||
pairToKeyValue _ = Nothing
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -71,12 +71,15 @@ library
|
|||
|
||||
-- other-extensions:
|
||||
build-depends: base >=4.15.1.0
|
||||
, aeson
|
||||
, bytestring
|
||||
, containers
|
||||
, megaparsec
|
||||
, prettyprinter
|
||||
, safe
|
||||
, scientific
|
||||
, text
|
||||
, vector
|
||||
|
||||
hs-source-dirs: lib
|
||||
default-language: Haskell2010
|
||||
|
|
@ -86,6 +89,8 @@ test-suite spec
|
|||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Data.Config.Suckless.KeyValueSpec
|
||||
Data.Config.Suckless.AesonSpec
|
||||
|
||||
hs-source-dirs:
|
||||
test
|
||||
ghc-options:
|
||||
|
|
@ -97,9 +102,13 @@ test-suite spec
|
|||
hspec-discover:hspec-discover
|
||||
build-depends: base
|
||||
, hspec
|
||||
, aeson
|
||||
, scientific
|
||||
, suckless-conf
|
||||
, containers
|
||||
, mtl
|
||||
, prettyprinter
|
||||
, interpolatedstring-perl6
|
||||
|
||||
default-language: Haskell2010
|
||||
default-extensions:
|
||||
|
|
|
|||
|
|
@ -2,3 +2,33 @@
|
|||
foo "a"
|
||||
bar "a"
|
||||
bar "b"
|
||||
|
||||
int1 122
|
||||
int2 0
|
||||
int3 -22
|
||||
int4 0xFAFA
|
||||
int5 0b11111111
|
||||
int6 -0xFAFA
|
||||
|
||||
(jopa-kita)
|
||||
|
||||
(sci1 1e9)
|
||||
(sci2 0.003)
|
||||
(sci3 -0.001)
|
||||
(sci4 -2e11)
|
||||
(sci5 -2e-3)
|
||||
|
||||
(wtf1 .001)
|
||||
|
||||
some-object {object ( key : 42) }
|
||||
|
||||
{another-object
|
||||
(object
|
||||
( key1 : 42 )
|
||||
( key2 : #f )
|
||||
( key3 : [ 1 2 3 4 ] )
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,86 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module Data.Config.Suckless.AesonSpec (spec) where
|
||||
|
||||
import Data.Config.Suckless.KeyValue
|
||||
import Data.Config.Suckless.Parse
|
||||
import Data.Config.Suckless.Syntax
|
||||
import Data.Functor
|
||||
import Data.Function
|
||||
import Data.Scientific
|
||||
-- import Data.Set (Set)
|
||||
-- import qualified Data.Set as Set
|
||||
import Prettyprinter
|
||||
import Text.InterpolatedString.Perl6 (qc,q)
|
||||
import Data.Aeson
|
||||
import Test.Hspec
|
||||
|
||||
|
||||
readConfig :: String -> IO [Syntax C]
|
||||
readConfig s = do
|
||||
pure $ parseTop s & either mempty id
|
||||
-- print $ pretty f
|
||||
-- pure f
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "toJSON" $ do
|
||||
|
||||
it "reads int" $ do
|
||||
c <- readConfig [qc|1|] <&> toJSON
|
||||
c `shouldBe` toJSON [1::Int]
|
||||
|
||||
it "reads scientific" $ do
|
||||
c <- readConfig [qc|1.00|] <&> toJSON
|
||||
c `shouldBe` toJSON [1.00 :: Scientific]
|
||||
|
||||
it "reads bool" $ do
|
||||
t <- readConfig [qc|#t|] <&> toJSON . head
|
||||
t `shouldBe` toJSON [Bool True]
|
||||
f <- readConfig [qc|#f|] <&> toJSON . head
|
||||
f `shouldBe` toJSON [Bool False]
|
||||
|
||||
it "reads string" $ do
|
||||
s <- readConfig [qc|"somestring"|] <&> toJSON
|
||||
s `shouldBe` toJSON ["somestring" :: String]
|
||||
|
||||
it "reads array" $ do
|
||||
s <- readConfig [qc|(1 2 3 4)|] <&> toJSON . head
|
||||
print s
|
||||
s `shouldBe` toJSON [1::Int,2,3,4]
|
||||
|
||||
it "reads simple object" $ do
|
||||
s <- readConfig [qc|
|
||||
(object
|
||||
(key1 : 22)
|
||||
(key2 : #f)
|
||||
(key3 : [1 2 3 4])
|
||||
(key4 : (object (o1 : "bebe")) )
|
||||
("fafa" : "fifa")
|
||||
(none : #nil)
|
||||
)
|
||||
|] <&> toJSON . head
|
||||
|
||||
let s1 = decode @Value [q|
|
||||
{
|
||||
"key1": 22,
|
||||
"key2": false,
|
||||
"key3": [1, 2, 3, 4],
|
||||
"key4": {
|
||||
"o1": "bebe"
|
||||
},
|
||||
"fafa" : "fifa",
|
||||
"none" : null
|
||||
}
|
||||
|
||||
|]
|
||||
|
||||
print s
|
||||
print s1
|
||||
Just s `shouldBe` s1
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Data.Config.Suckless.KeyValueSpec (spec) where
|
||||
|
|
@ -8,8 +9,12 @@ import Data.Config.Suckless.KeyValue
|
|||
import Data.Config.Suckless.Parse
|
||||
import Data.Config.Suckless.Syntax
|
||||
import Data.Functor
|
||||
import Data.Scientific
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Prettyprinter
|
||||
import Data.Aeson
|
||||
import Text.InterpolatedString.Perl6 (qc,q)
|
||||
import Test.Hspec
|
||||
|
||||
data FirstKey
|
||||
|
|
@ -18,6 +23,22 @@ data SecondKey
|
|||
|
||||
data ThirdKey
|
||||
|
||||
data Int1
|
||||
data Int2
|
||||
data Int3
|
||||
data Int4
|
||||
data Int5
|
||||
data Int6
|
||||
|
||||
data Sci1
|
||||
data Sci2
|
||||
data Sci3
|
||||
data Sci4
|
||||
data Sci5
|
||||
|
||||
data O1
|
||||
data O2
|
||||
|
||||
instance MonadIO m => HasCfgKey FirstKey (Maybe String) m where
|
||||
key = "foo"
|
||||
|
||||
|
|
@ -27,23 +48,117 @@ instance MonadIO m => HasCfgKey SecondKey (Set String) m where
|
|||
instance MonadIO m => HasCfgKey ThirdKey (Maybe String) m where
|
||||
key = "baz"
|
||||
|
||||
instance MonadIO m => HasCfgKey Int1 b m where
|
||||
key = "int1"
|
||||
|
||||
instance MonadIO m => HasCfgKey Int2 b m where
|
||||
key = "int2"
|
||||
|
||||
instance MonadIO m => HasCfgKey Int3 b m where
|
||||
key = "int3"
|
||||
|
||||
instance MonadIO m => HasCfgKey Int4 b m where
|
||||
key = "int4"
|
||||
|
||||
instance MonadIO m => HasCfgKey Int5 b m where
|
||||
key = "int5"
|
||||
|
||||
instance MonadIO m => HasCfgKey Int6 b m where
|
||||
key = "int6"
|
||||
|
||||
instance MonadIO m => HasCfgKey Sci1 b m where
|
||||
key = "sci1"
|
||||
|
||||
instance MonadIO m => HasCfgKey Sci2 b m where
|
||||
key = "sci2"
|
||||
|
||||
instance MonadIO m => HasCfgKey Sci3 b m where
|
||||
key = "sci3"
|
||||
|
||||
instance MonadIO m => HasCfgKey Sci4 b m where
|
||||
key = "sci4"
|
||||
|
||||
instance MonadIO m => HasCfgKey Sci5 b m where
|
||||
key = "sci5"
|
||||
|
||||
instance MonadIO m => HasCfgKey O1 b m where
|
||||
key = "some-object"
|
||||
|
||||
instance MonadIO m => HasCfgKey O2 b m where
|
||||
key = "another-object"
|
||||
|
||||
instance (Monad m, MonadIO m) => HasConf m where
|
||||
getConf = liftIO readConfig
|
||||
|
||||
readConfig :: IO [Syntax C]
|
||||
readConfig = do
|
||||
let configFilePath = "t/key-value-test-config"
|
||||
readFile configFilePath <&> parseTop <&> either mempty id
|
||||
f <- readFile configFilePath <&> parseTop <&> either mempty id
|
||||
print $ pretty f
|
||||
pure f
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "config parsing" $ do
|
||||
|
||||
it "reads string" $ do
|
||||
firstValue <- cfgValue @FirstKey @(Maybe String)
|
||||
firstValue `shouldBe` Just "a"
|
||||
|
||||
it "reads a set of strings" $ do
|
||||
secondValue <- cfgValue @SecondKey @(Set String)
|
||||
secondValue `shouldBe` Set.fromList ["a", "b"]
|
||||
|
||||
it "reads nothing" $ do
|
||||
thridValue <- cfgValue @ThirdKey @(Maybe String)
|
||||
thridValue `shouldBe` Nothing
|
||||
thridValue `shouldBe` Nothing
|
||||
|
||||
it "reads ints" $ do
|
||||
x1 <- cfgValue @Int1 @(Maybe Integer)
|
||||
x1 `shouldBe` Just 122
|
||||
|
||||
x2 <- cfgValue @Int2
|
||||
x2 `shouldBe` Just (0 :: Integer)
|
||||
|
||||
x3 <- cfgValue @Int3
|
||||
x3 `shouldBe` Just (-22 :: Integer)
|
||||
|
||||
x4 <- cfgValue @Int4 @(Maybe Integer)
|
||||
x4 `shouldBe` Just 0xFAFA
|
||||
|
||||
x5 <- cfgValue @Int5 @(Maybe Integer)
|
||||
x5 `shouldBe` Just 255
|
||||
|
||||
x6 <- cfgValue @Int6 @(Maybe Integer)
|
||||
x6 `shouldBe` Just (-0xFAFA)
|
||||
|
||||
it "reads scientifics" $ do
|
||||
x1 <- cfgValue @Sci1 @(Maybe Scientific)
|
||||
x1 `shouldBe` Just 1e9
|
||||
|
||||
x2 <- cfgValue @Sci2 @(Maybe Scientific)
|
||||
x2 `shouldBe` Just 0.003
|
||||
|
||||
-- x3 <- cfgValue @Sci3 @(Maybe Scientific)
|
||||
-- x3 `shouldBe` Just (-0.001)
|
||||
|
||||
x4 <- cfgValue @Sci4 @(Maybe Scientific)
|
||||
x4 `shouldBe` Just (-2e11)
|
||||
|
||||
x5 <- cfgValue @Sci5 @(Maybe Scientific)
|
||||
x5 `shouldBe` Just (-2e-3)
|
||||
|
||||
it "reads objects" $ do
|
||||
o1 <- cfgValue @O1 @(Maybe Value)
|
||||
let wtf1 = [q|{ "key" : 42 }|]
|
||||
o1 `shouldBe` decode wtf1
|
||||
let wtf2 = [q|
|
||||
{ "key1" : 42
|
||||
, "key2" : false
|
||||
, "key3" : [ 1, 2, 3, 4]
|
||||
}
|
||||
|]
|
||||
o2 <- cfgValue @O2 @(Maybe Value)
|
||||
o2 `shouldBe` decode wtf2
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue