From ae1449767faa3fa5a262b74b7a3b444c83b967cf Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 19 Sep 2023 06:54:54 +0300 Subject: [PATCH] ToJSON for Syntax --- lib/Data/Config/Suckless/KeyValue.hs | 61 +++++++++- lib/Data/Config/Suckless/Parse/Megaparsec.hs | 48 ++++++-- lib/Data/Config/Suckless/Syntax.hs | 36 ++++++ suckless-conf.cabal | 9 ++ t/key-value-test-config | 30 +++++ test/Data/Config/Suckless/AesonSpec.hs | 86 ++++++++++++++ test/Data/Config/Suckless/KeyValueSpec.hs | 119 ++++++++++++++++++- 7 files changed, 374 insertions(+), 15 deletions(-) create mode 100644 test/Data/Config/Suckless/AesonSpec.hs diff --git a/lib/Data/Config/Suckless/KeyValue.hs b/lib/Data/Config/Suckless/KeyValue.hs index 397f087..61e2c96 100644 --- a/lib/Data/Config/Suckless/KeyValue.hs +++ b/lib/Data/Config/Suckless/KeyValue.hs @@ -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 - ] \ No newline at end of file + ] + + diff --git a/lib/Data/Config/Suckless/Parse/Megaparsec.hs b/lib/Data/Config/Suckless/Parse/Megaparsec.hs index 58ca2b5..304dce2 100644 --- a/lib/Data/Config/Suckless/Parse/Megaparsec.hs +++ b/lib/Data/Config/Suckless/Parse/Megaparsec.hs @@ -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 ] diff --git a/lib/Data/Config/Suckless/Syntax.hs b/lib/Data/Config/Suckless/Syntax.hs index 6647ddf..0657234 100644 --- a/lib/Data/Config/Suckless/Syntax.hs +++ b/lib/Data/Config/Suckless/Syntax.hs @@ -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 + + + diff --git a/suckless-conf.cabal b/suckless-conf.cabal index 093d8f5..1af304c 100644 --- a/suckless-conf.cabal +++ b/suckless-conf.cabal @@ -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: diff --git a/t/key-value-test-config b/t/key-value-test-config index 2766052..2e8f7a9 100644 --- a/t/key-value-test-config +++ b/t/key-value-test-config @@ -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 ] ) + ) +} + + + diff --git a/test/Data/Config/Suckless/AesonSpec.hs b/test/Data/Config/Suckless/AesonSpec.hs new file mode 100644 index 0000000..32a9c81 --- /dev/null +++ b/test/Data/Config/Suckless/AesonSpec.hs @@ -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 + + + + + diff --git a/test/Data/Config/Suckless/KeyValueSpec.hs b/test/Data/Config/Suckless/KeyValueSpec.hs index 80a3b6a..4766fde 100644 --- a/test/Data/Config/Suckless/KeyValueSpec.hs +++ b/test/Data/Config/Suckless/KeyValueSpec.hs @@ -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 \ No newline at end of file + 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 + +