Much better handling for the generic syntax tree.

It now converts normal data into JSON rather than using "show".

1 files changed, 32 insertions, 30 deletions

diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index 165949a..e951623 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -27,15 +27,15 @@ import Language.Fiddle.Types
 type Context stage =
   ( Show (NumberType stage),
     Typeable stage,
-    ToGenericSyntaxTreeValue (NumberType stage),
-    Show (ImportInterface stage),
-    Show (FiddleUnitInterface stage),
-    Show (QualificationMetadata stage ()),
-    Show (QualificationMetadata stage ExportedPackageDecl),
-    Show (QualificationMetadata stage ExportedLocationDecl),
-    Show (QualificationMetadata stage ExportedBitsDecl),
-    Show (QualificationMetadata stage ExportedTypeDecl),
-    Show (QualificationMetadata stage ExportedObjectDecl)
+    ToJSON (NumberType stage),
+    ToJSON (ImportInterface stage),
+    ToJSON (FiddleUnitInterface stage),
+    ToJSON (QualificationMetadata stage ()),
+    ToJSON (QualificationMetadata stage ExportedPackageDecl),
+    ToJSON (QualificationMetadata stage ExportedLocationDecl),
+    ToJSON (QualificationMetadata stage ExportedBitsDecl),
+    ToJSON (QualificationMetadata stage ExportedTypeDecl),
+    ToJSON (QualificationMetadata stage ExportedObjectDecl)
   )
 
 class FunctorShow f where
@@ -62,7 +62,7 @@ data GenericSyntaxTree f a where
     GenericSyntaxTree f a
   SyntaxTreeList :: [GenericSyntaxTree f a] -> GenericSyntaxTree f a
   SyntaxTreeDeferred :: f (GenericSyntaxTree f a) -> GenericSyntaxTree f a
-  SyntaxTreeValue :: String -> GenericSyntaxTree f a
+  SyntaxTreeValue :: Value -> GenericSyntaxTree f a
 
 alterGenericSyntaxTree ::
   (Functor f) =>
@@ -103,7 +103,7 @@ instance (Foldable f) => ToJSON (GenericSyntaxTree f (Maybe Value)) where
       Array $ Data.Vector.fromList $ map toJSON l
     (SyntaxTreeDeferred fdef) ->
       toJSON (SyntaxTreeList $ Data.Foldable.toList fdef)
-    (SyntaxTreeValue s) -> String (Data.Text.pack s)
+    (SyntaxTreeValue s) -> toJSON s
 
   toEncoding = \case
     (SyntaxTreeObject typ membs (Just a) t) ->
@@ -114,26 +114,23 @@ instance (Foldable f) => ToJSON (GenericSyntaxTree f (Maybe Value)) where
       foldable $ map toJSON l
     (SyntaxTreeDeferred fdef) ->
       toEncoding (SyntaxTreeList $ Data.Foldable.toList fdef)
-    (SyntaxTreeValue s) -> text (Data.Text.pack s)
+    (SyntaxTreeValue v) -> toEncoding v
 
-class ToGenericSyntaxTreeValue v where
-  toGenericSyntaxTreeValue :: forall f a. v -> Maybe (GenericSyntaxTree f a)
+class ToGenericSyntaxTreeValue f v where
+  toGenericSyntaxTreeValue :: forall a. v -> Maybe (GenericSyntaxTree f a)
   default toGenericSyntaxTreeValue ::
-    forall f a. (Show v) => v -> Maybe (GenericSyntaxTree f a)
-  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . show
+    forall a. (ToJSON v) => v -> Maybe (GenericSyntaxTree f a)
+  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . toJSON
 
-instance ToGenericSyntaxTreeValue (f a) where
-  toGenericSyntaxTreeValue = const Nothing
+instance ToGenericSyntaxTreeValue f Data.Text.Text where
+  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . String
 
-instance ToGenericSyntaxTreeValue Data.Text.Text where
-  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . Data.Text.unpack
-
-instance (Show s) => ToGenericSyntaxTreeValue s where
-  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . show
+instance (ToJSON s) => ToGenericSyntaxTreeValue f s where
+  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . toJSON
 
 -- Witnesses exist just for type level meta programming, don't return anything
 -- if we don't need it.
-instance ToGenericSyntaxTreeValue (Witness b) where
+instance ToGenericSyntaxTreeValue f (Witness b) where
   toGenericSyntaxTreeValue _ = Nothing
 
 type GenericContext t f a = (Traversable f, ToGenericSyntaxTree t, Typeable t, Typeable f, Typeable a)
@@ -152,7 +149,7 @@ class GToGenericSyntaxTree r f a where
 class GToMemberList r f a where
   gToMemberList :: Int -> r x -> [GenericSyntaxTree f a]
 
-instance (ToGenericSyntaxTreeValue v) => GToMemberList (Rec0 v) f a where
+instance (ToGenericSyntaxTreeValue f v) => GToMemberList (Rec0 v) f a where
   gToMemberList _ = toList . toGenericSyntaxTreeValue . unK1
 
 instance
@@ -161,10 +158,10 @@ instance
   where
   gToGenericSyntaxTree _ k1 = SyntaxTreeDeferred (toGenericSyntaxTree <$> unK1 k1)
 
-instance
-  GToGenericSyntaxTree (Rec0 (f x)) f a
-  where
-  gToGenericSyntaxTree _ k1 = SyntaxTreeList []
+-- instance
+--   GToGenericSyntaxTree (Rec0 (f x)) f a
+--   where
+--   gToGenericSyntaxTree _ k1 = SyntaxTreeList []
 
 instance
   (GenericContext r f a, Traversable f1) =>
@@ -254,7 +251,12 @@ deriving instance (Context stage) => (ToGenericSyntaxTree (ObjTypeBody stage))
 
 deriving instance (Context stage) => (ToGenericSyntaxTree (ObjTypeDecl stage))
 
-deriving instance (ToGenericSyntaxTreeValue ModifierKeyword)
+instance (ToGenericSyntaxTreeValue f ModifierKeyword) where
+  toGenericSyntaxTreeValue kw = Just $ SyntaxTreeValue $ String (Data.Text.pack $ show kw)
+
+instance (Functor f, ToJSON a) => (ToGenericSyntaxTreeValue f (f a)) where
+  toGenericSyntaxTreeValue mv =
+     Just $ SyntaxTreeDeferred $ SyntaxTreeValue . toJSON <$> mv
 
 deriving instance (ToGenericSyntaxTree Modifier)