ToJSON for Syntax

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
                 ]
+
+

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!
+numLit :: forall c . MegaConstraints c
-intLit :: 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
+    sign :: forall a . Num a => Bool -> a -> a
-    oct = L.symbol sc "0o" >> L.octal
+    sign x = if x then negate else id
-    bin = L.symbol sc "0b" >> L.binary
-    dec = L.decimal
-    dec'= signed sc L.decimal
 
 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
                    ]
 

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
+
+
+

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:

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 ] )
+  )
+}
+
+
+

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
+
+
+
+
+

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
+
+    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
+
+