1 files changed, 24 insertions, 75 deletions
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index 598336a..59db6aa 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -14,6 +14,7 @@ import Control.Monad.Writer (execWriter, tell)
 import Data.Aeson (Value (..), foldable, object, toEncoding, toJSON)
 import Data.Aeson.Encoding (text)
 import Data.Aeson.Types as Aeson
+import Data.Foldable (Foldable (toList))
 import qualified Data.Foldable
 import Data.Functor.Classes (Show1, liftShowsPrec)
 import Data.Kind (Type)
@@ -32,7 +33,8 @@ type Context stage =
   ( Show (NumberType stage),
     Typeable stage,
     ToGenericSyntaxTree (ImportType stage),
-    Typeable (ImportType stage)
+    Typeable (ImportType stage),
+    ToGenericSyntaxTreeValue (NumberType stage)
   )
 
 data GenericSyntaxTree f a where
@@ -89,17 +91,25 @@ instance (Foldable f, ToJSON a) => ToJSON (GenericSyntaxTree f a) where
     (SyntaxTreeValue s) -> text (Data.Text.pack s)
 
 class ToGenericSyntaxTreeValue v where
-  toGenericSyntaxTreeValue :: forall f a. v -> GenericSyntaxTree f a
+  toGenericSyntaxTreeValue :: forall f a. v -> Maybe (GenericSyntaxTree f a)
   default toGenericSyntaxTreeValue ::
-    forall f a. (Show v) => v -> GenericSyntaxTree f a
-  toGenericSyntaxTreeValue = SyntaxTreeValue . show
+    forall f a. (Show v) => v -> Maybe (GenericSyntaxTree f a)
+  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . show
 
 instance ToGenericSyntaxTreeValue Data.Text.Text where
-  toGenericSyntaxTreeValue = SyntaxTreeValue . Data.Text.unpack
+  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . Data.Text.unpack
+
+instance (Show s, Num s) => ToGenericSyntaxTreeValue s where
+  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . show
+
+-- Witnesses exist just for type level meta programming, don't return anything
+-- if we don't need it.
+instance ToGenericSyntaxTreeValue (Witness b) where
+  toGenericSyntaxTreeValue _ = Nothing
 
 type GenericContext t f a = (Traversable f, ToGenericSyntaxTree t, Typeable t, Typeable f, Typeable a)
 
-class ToGenericSyntaxTree (t :: SynTreeKind) where
+class ToGenericSyntaxTree (t :: SynTree) where
   toGenericSyntaxTree :: (Traversable f, Typeable f, Typeable t, Typeable a) => t f a -> GenericSyntaxTree f a
   default toGenericSyntaxTree ::
     (GenericContext t f a, Generic (t f a), (GToGenericSyntaxTree (Rep (t f a)) f a)) =>
@@ -114,7 +124,7 @@ class GToMemberList r f a where
   gToMemberList :: Int -> r x -> [GenericSyntaxTree f a]
 
 instance (ToGenericSyntaxTreeValue v) => GToMemberList (Rec0 v) f a where
-  gToMemberList _ = (: []) . toGenericSyntaxTreeValue . unK1
+  gToMemberList _ = toList . toGenericSyntaxTreeValue . unK1
 
 instance
   (GenericContext r f a) =>
@@ -195,64 +205,19 @@ deriving instance (ToGenericSyntaxTree ImportList)
 
 deriving instance (ToGenericSyntaxTree ImportStatement)
 
-deriving instance (ToGenericSyntaxTree t, Typeable t) => (ToGenericSyntaxTree (Directed t))
+deriving instance
+  (Context stage, ToGenericSyntaxTree (t stage), Typeable t) =>
+  (ToGenericSyntaxTree (Directed t stage))
 
 deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleUnit stage))
 
 deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleDecl stage))
 
-instance (Context stage) => ToGenericSyntaxTree (ObjType stage) where
-  toGenericSyntaxTree t = case t of
-    (AnonymousObjType body annot) ->
-      SyntaxTreeDeferred $
-        fmap
-          ( \body' ->
-              SyntaxTreeObject
-                "AnonymousObjType"
-                [toGenericSyntaxTree body']
-                annot
-                body'
-          )
-          body
-    (ArrayObjType arr expr annot) ->
-      SyntaxTreeObject
-        "ArrayObjType"
-        [toGenericSyntaxTree arr, toGenericSyntaxTree expr]
-        annot
-        t
-    (ReferencedObjType ident a) ->
-      SyntaxTreeObject "ReferencedObjType" [toGenericSyntaxTree ident] a t
+deriving instance (Context stage) => ToGenericSyntaxTree (ObjType stage)
 
 deriving instance (Context stage) => (ToGenericSyntaxTree (ObjTypeBody stage))
 
-instance (Context stage) => (ToGenericSyntaxTree (ObjTypeDecl stage)) where
-  toGenericSyntaxTree t = case t of
-    (AssertPosStatement expr a) ->
-      SyntaxTreeObject "AssertPosStatement" [toGenericSyntaxTree expr] a t
-    (TypeSubStructure body mIdent a) ->
-      SyntaxTreeObject
-        "TypeSubStructure"
-        ( Data.Foldable.toList (toGenericSyntaxTree <$> body)
-            ++ Data.Foldable.toList (toGenericSyntaxTree <$> mIdent)
-        )
-        a
-        t
-    (ReservedDecl expr a) ->
-      SyntaxTreeObject
-        "ReservedDecl"
-        [toGenericSyntaxTree expr]
-        a
-        t
-    (RegisterDecl mMod mIdent expr mBody a) ->
-      SyntaxTreeObject
-        "RegisterDecl"
-        ( Data.Foldable.toList (toGenericSyntaxTree <$> mMod)
-            ++ Data.Foldable.toList (toGenericSyntaxTree <$> mIdent)
-            ++ [toGenericSyntaxTree expr]
-            ++ Data.Foldable.toList (toGenericSyntaxTree <$> mBody)
-        )
-        a
-        t
+deriving instance (Context stage) => (ToGenericSyntaxTree (ObjTypeDecl stage))
 
 deriving instance (ToGenericSyntaxTreeValue ModifierKeyword)
 
@@ -264,20 +229,7 @@ deriving instance (Context stage) => (ToGenericSyntaxTree (RegisterBody stage))
 
 deriving instance (Context stage) => (ToGenericSyntaxTree (RegisterBitsDecl stage))
 
-instance (Context stage) => ToGenericSyntaxTree (RegisterBitsTypeRef stage) where
-  toGenericSyntaxTree t = case t of
-    (RegisterBitsArray ref exp a) ->
-      SyntaxTreeObject
-        "RegisterBitsArray"
-        [toGenericSyntaxTree ref, toGenericSyntaxTree exp]
-        a
-        t
-    (RegisterBitsReference i a) ->
-      SyntaxTreeObject "RegisterBitsReference" [toGenericSyntaxTree i] a t
-    (RegisterBitsAnonymousType t a) ->
-      SyntaxTreeObject "RegisterBitsAnonymousType " [toGenericSyntaxTree t] a t
-    (RegisterBitsJustBits t a) ->
-      SyntaxTreeObject "RegisterBitsJustBits " [toGenericSyntaxTree t] a t
+deriving instance (Context stage) => ToGenericSyntaxTree (RegisterBitsTypeRef stage)
 
 deriving instance (Context stage) => (ToGenericSyntaxTree (AnonymousBitsType stage))
 
@@ -289,7 +241,4 @@ deriving instance (Context stage) => (ToGenericSyntaxTree (EnumConstantDecl stag
 
 deriving instance (Context stage) => (ToGenericSyntaxTree (PackageBody stage))
 
-instance (Context stage) => (ToGenericSyntaxTree (Expression stage)) where
-  toGenericSyntaxTree tr = case tr of
-    LitNum t a -> SyntaxTreeObject "LitNum" [SyntaxTreeValue (show t)] a tr
-    Var t a -> SyntaxTreeObject "LitNum" [toGenericSyntaxTree t] a tr
+deriving instance (Context stage) => (ToGenericSyntaxTree (Expression stage))