Change syntax trees to include the names of the records.

1 files changed, 22 insertions, 20 deletions

diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index cbaf447..e83a2b4 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -10,9 +10,12 @@
 
 module Language.Fiddle.GenericTree where
 
+import Control.Arrow (Arrow (second))
 import Control.Monad.Identity (Identity)
 import Data.Aeson.Encoding (text)
+import Data.Aeson.Key (fromString)
 import Data.Aeson.Types as Aeson
+import Data.Bifunctor (Bifunctor (bimap, first))
 import Data.Foldable (Foldable (toList))
 import Data.Proxy
 import qualified Data.Text
@@ -57,7 +60,7 @@ data GenericSyntaxTree f a where
     forall t f a.
     (Typeable t, Typeable f, Typeable a) =>
     String ->
-    [GenericSyntaxTree f a] ->
+    [(String, GenericSyntaxTree f a)] ->
     a ->
     t f a ->
     GenericSyntaxTree f a
@@ -77,7 +80,7 @@ alterGenericSyntaxTree fn genericTree
         SyntaxTreeObject str members a tree ->
           SyntaxTreeObject
             str
-            (map (alterGenericSyntaxTree fn) members)
+            (map (second (alterGenericSyntaxTree fn)) members)
             a
             tree
         SyntaxTreeList members ->
@@ -97,25 +100,16 @@ instance (ToJSON a) => ToJSON (Commented a) where
 instance (Foldable f) => ToJSON (GenericSyntaxTree f (Maybe Value)) where
   toJSON = \case
     (SyntaxTreeObject typ membs Nothing _) ->
-      object ["_con" .= typ, "_members" .= membs]
+      object $ ("_con" .= typ) : map (uncurry (.=) . bimap fromString toJSON) membs
     (SyntaxTreeObject typ membs (Just a) _) ->
-      object ["_con" .= typ, "_members" .= membs, "_annot" .= a]
+      object $ ("_con" .= typ) : ("_annot" .= a) : map (uncurry (.=) . bimap fromString toJSON) membs
     (SyntaxTreeList l) ->
       Array $ Data.Vector.fromList $ map toJSON l
     (SyntaxTreeDeferred fdef) ->
       toJSON (SyntaxTreeList $ Data.Foldable.toList fdef)
     (SyntaxTreeValue s) -> toJSON s
 
-  toEncoding = \case
-    (SyntaxTreeObject typ membs (Just a) t) ->
-      pairs $ "_type" .= show (typeOf t) <> "_con" .= typ <> "_members" .= membs <> "_annot" .= a
-    (SyntaxTreeObject typ membs Nothing t) ->
-      pairs $ "_type" .= show (typeOf t) <> "_con" .= typ <> "_members" .= membs
-    (SyntaxTreeList l) ->
-      foldable $ map toJSON l
-    (SyntaxTreeDeferred fdef) ->
-      toEncoding (SyntaxTreeList $ Data.Foldable.toList fdef)
-    (SyntaxTreeValue v) -> toEncoding v
+  toEncoding = toEncoding . toJSON
 
 class ToGenericSyntaxTreeValue f v where
   toGenericSyntaxTreeValue :: forall a. v -> Maybe (GenericSyntaxTree f a)
@@ -148,10 +142,10 @@ class GToGenericSyntaxTree r f a where
   gToGenericSyntaxTree :: (Typeable t, Typeable f, Typeable a) => t f a -> r x -> GenericSyntaxTree f a
 
 class GToMemberList r f a where
-  gToMemberList :: Int -> r x -> [GenericSyntaxTree f a]
+  gToMemberList :: Int -> r x -> [(String, GenericSyntaxTree f a)]
 
 instance (ToGenericSyntaxTreeValue f v) => GToMemberList (Rec0 v) f a where
-  gToMemberList _ = toList . toGenericSyntaxTreeValue . unK1
+  gToMemberList n = toList . fmap ("_" ++ show n,) . toGenericSyntaxTreeValue . unK1
 
 instance
   (GenericContext r f a) =>
@@ -172,6 +166,15 @@ instance
     SyntaxTreeList (Data.Foldable.toList $ toGenericSyntaxTree <$> unK1 k1)
 
 instance
+  (GToMemberList r f a, KnownSymbol name) =>
+  GToMemberList (M1 S ('MetaSel ('Just name) u1 u2 u3) r) f a
+  where
+  gToMemberList n (M1 m) = map (first (const sval)) $ gToMemberList n m
+    where
+      sval :: String
+      sval = symbolVal (Proxy :: Proxy name)
+
+instance
   (GToMemberList r f a, GToMemberList l f a) =>
   GToMemberList (l :*: r) f a
   where
@@ -180,14 +183,13 @@ instance
       l1 = gToMemberList n l
 
 instance (GenericContext t f a) => GToMemberList (Rec0 (t f a)) f a where
-  gToMemberList _ a = [toGenericSyntaxTree (unK1 a)]
-
+  gToMemberList n a = [("_" ++ show n, toGenericSyntaxTree (unK1 a))]
 
 instance
   (GenericContext t f a, Foldable l) =>
   GToMemberList (Rec0 (l (t f a))) f a
   where
-  gToMemberList _ as = toGenericSyntaxTree <$> Data.Foldable.toList (unK1 as)
+  gToMemberList n as = [("_" ++ show n, SyntaxTreeList (toGenericSyntaxTree <$> Data.Foldable.toList (unK1 as)))]
 
 instance GToMemberList (Rec0 a) f a where
   gToMemberList _ _ = []
@@ -257,7 +259,7 @@ instance (ToGenericSyntaxTreeValue f ModifierKeyword) where
 
 instance (Functor f, ToJSON a) => (ToGenericSyntaxTreeValue f (f a)) where
   toGenericSyntaxTreeValue mv =
-     Just $ SyntaxTreeDeferred $ SyntaxTreeValue . toJSON <$> mv
+    Just $ SyntaxTreeDeferred $ SyntaxTreeValue . toJSON <$> mv
 
 deriving instance (ToGenericSyntaxTree Modifier)