From eef15613402380b9b67c68a0e8a22a71250daa98 Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Tue, 19 Sep 2023 12:35:51 +0300
Subject: [PATCH] FromJSON for Syntax

---
 lib/Data/Config/Suckless/Syntax.hs     | 27 +++++++++++++++++++-
 suckless-conf.cabal                    |  1 +
 test/Data/Config/Suckless/AesonSpec.hs | 35 +++++++++++++++++++++++---
 3 files changed, 58 insertions(+), 5 deletions(-)

diff --git a/lib/Data/Config/Suckless/Syntax.hs b/lib/Data/Config/Suckless/Syntax.hs
index 0657234..3b1fa91 100644
--- a/lib/Data/Config/Suckless/Syntax.hs
+++ b/lib/Data/Config/Suckless/Syntax.hs
@@ -28,7 +28,9 @@ import GHC.Generics
 import Data.Maybe
 import Data.Aeson
 import Data.Aeson.Key
-import qualified Data.Vector as V
+import Data.Aeson.KeyMap qualified as Aeson
+import Data.Vector qualified as V
+import Data.Traversable (forM)
 
 import Prettyprinter
 
@@ -57,6 +59,11 @@ data family Context c :: Type
 class IsContext c where
   noContext :: Context c
 
+data instance Context () = EmptyContext
+
+instance IsContext () where
+  noContext = EmptyContext
+
 class HasContext c a where
   setContext :: Context c -> a -> a
   getContext :: a -> Context c
@@ -151,3 +158,21 @@ instance ToJSON (Syntax c) where
 
 
 
+instance FromJSON (Syntax ()) where
+    parseJSON (String t) = pure $ Literal noContext (LitStr t)
+    parseJSON (Number n)
+        | isInteger n = pure $ Literal noContext (LitInt (floor n))
+        | otherwise   = pure $ Literal noContext (LitScientific n)
+    parseJSON (Bool b)  = pure $ Literal noContext (LitBool b)
+    parseJSON (Array a) = List noContext <$> mapM parseJSON (V.toList a)
+    parseJSON (Object o) = do
+        pairs <- forM (Aeson.toList o) $ \(key, value) -> do
+            valueSyntax <- parseJSON value
+            pure $ List noContext [ Symbol noContext (Id (toText key))
+                                  , Symbol noContext ":"
+                                  , valueSyntax
+                                  ]
+        pure $ List noContext (Symbol noContext (Id "object") : pairs)
+    parseJSON _ = fail "Cannot parse JSON to Syntax"
+
+
diff --git a/suckless-conf.cabal b/suckless-conf.cabal
index 1af304c..b7423ef 100644
--- a/suckless-conf.cabal
+++ b/suckless-conf.cabal
@@ -80,6 +80,7 @@ library
                     , scientific
                     , text
                     , vector
+                    , unordered-containers
 
     hs-source-dirs:   lib
     default-language: Haskell2010
diff --git a/test/Data/Config/Suckless/AesonSpec.hs b/test/Data/Config/Suckless/AesonSpec.hs
index 32a9c81..c1ae8d8 100644
--- a/test/Data/Config/Suckless/AesonSpec.hs
+++ b/test/Data/Config/Suckless/AesonSpec.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 module Data.Config.Suckless.AesonSpec (spec) where
 
@@ -9,12 +10,13 @@ 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 GHC.Generics hiding (C)
 import Text.InterpolatedString.Perl6 (qc,q)
 import Data.Aeson
+import Data.Maybe
 import Test.Hspec
+import Prettyprinter
 
 
 readConfig :: String -> IO [Syntax C]
@@ -23,6 +25,17 @@ readConfig s = do
   -- print $ pretty f
   -- pure f
 
+data SomeData =
+  SomeData
+  { someDataKey1 :: Int
+  , someDataKey2 :: String
+  , someDataKey3 :: [Scientific]
+  }
+  deriving stock (Generic,Show,Eq)
+
+instance ToJSON SomeData
+instance FromJSON SomeData
+
 spec :: Spec
 spec = do
   describe "toJSON" $ do
@@ -81,6 +94,20 @@ spec = do
       Just s `shouldBe` s1
 
 
-
+    it "serializes object to syntax"  $ do
+      let some = SomeData 1 "some-data" [1, 2, 3, 4, 5, 10]
+
+      let someSyn = case fromJSON @(Syntax ()) (toJSON some) of
+                      Success syn -> Just syn
+                      _           -> Nothing
+
+      print $ pretty someSyn
+
+      let json = fromJust $ someSyn <&> toJSON
+
+      let someObject = fromJSON @SomeData json
+
+      print someObject
+      someObject `shouldBe` Success some