1 files changed, 211 insertions, 0 deletions
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
new file mode 100644
index 0000000..21cfa68
--- /dev/null
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -0,0 +1,211 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Language.Fiddle.GenericTree where
+
+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 qualified Data.Foldable
+import Data.Functor.Classes (Show1, liftShowsPrec)
+import Data.Proxy
+import qualified Data.Text
+import qualified Data.Vector
+import GHC.Generics
+import GHC.TypeLits (KnownSymbol, symbolVal)
+import Language.Fiddle.Ast
+import Text.Printf (printf)
+
+data GenericSyntaxTree f a where
+  {- GenericSyntaxtTree with a name and children. -}
+  SyntaxTreeObject ::
+    String ->
+    [GenericSyntaxTree f a] ->
+    a ->
+    GenericSyntaxTree f a
+  SyntaxTreeList :: [GenericSyntaxTree f a] -> GenericSyntaxTree f a
+  SyntaxTreeDeferred :: f (GenericSyntaxTree f a) -> GenericSyntaxTree f a
+  SyntaxTreeValue :: String -> GenericSyntaxTree f a
+
+instance (Foldable f, Show a) => ToJSON (GenericSyntaxTree f a) where
+  toJSON = \case
+    (SyntaxTreeObject typ membs a) ->
+      object ["_type" .= typ, "_members" .= membs, "_annot" .= show a]
+    (SyntaxTreeList l) ->
+      Array $ Data.Vector.fromList $ map toJSON l
+    (SyntaxTreeDeferred fdef) ->
+      toJSON (SyntaxTreeList $ Data.Foldable.toList fdef)
+    (SyntaxTreeValue s) -> String (Data.Text.pack s)
+
+  toEncoding = \case
+    (SyntaxTreeObject typ membs a) ->
+      pairs $ "_type" .= typ <> "_members" .= membs <> "_annot" .= show a
+    (SyntaxTreeList l) ->
+      foldable $ map toJSON l
+    (SyntaxTreeDeferred fdef) ->
+      toEncoding (SyntaxTreeList $ Data.Foldable.toList fdef)
+    (SyntaxTreeValue s) -> text (Data.Text.pack s)
+
+class ToGenericSyntaxTreeValue v where
+  toGenericSyntaxTreeValue :: forall f a. v -> GenericSyntaxTree f a
+  default toGenericSyntaxTreeValue ::
+    forall f a. (Show v) => v -> GenericSyntaxTree f a
+  toGenericSyntaxTreeValue = SyntaxTreeValue . show
+
+instance ToGenericSyntaxTreeValue Data.Text.Text where
+  toGenericSyntaxTreeValue = SyntaxTreeValue . Data.Text.unpack
+
+class ToGenericSyntaxTree (t :: (* -> *) -> * -> *) where
+  toGenericSyntaxTree :: (Traversable f) => t f a -> GenericSyntaxTree f a
+  default toGenericSyntaxTree ::
+    (Generic (t f a), (GToGenericSyntaxTree (Rep (t f a)) f a), (Traversable f)) =>
+    t f a ->
+    GenericSyntaxTree f a
+  toGenericSyntaxTree = gToGenericSyntaxTree . from
+
+class GToGenericSyntaxTree r f a where
+  gToGenericSyntaxTree :: r x -> GenericSyntaxTree f a
+
+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
+
+instance
+  (Traversable f, ToGenericSyntaxTree r) =>
+  GToGenericSyntaxTree (Rec0 (f (r f a))) f a
+  where
+  gToGenericSyntaxTree k1 = SyntaxTreeDeferred (toGenericSyntaxTree <$> unK1 k1)
+
+instance
+  (Traversable f, Traversable f1, ToGenericSyntaxTree r) =>
+  GToGenericSyntaxTree (Rec0 (f1 (r f a))) f a
+  where
+  gToGenericSyntaxTree k1 =
+    SyntaxTreeList (Data.Foldable.toList $ toGenericSyntaxTree <$> unK1 k1)
+
+instance
+  (GToMemberList r f a, GToMemberList l f a) =>
+  GToMemberList (l :*: r) f a
+  where
+  gToMemberList n (l :*: r) = l1 ++ gToMemberList (length l1) r
+    where
+      l1 = gToMemberList n l
+
+instance (ToGenericSyntaxTree t, Traversable f) => GToMemberList (Rec0 (t f a)) f a where
+  gToMemberList _ a = [toGenericSyntaxTree (unK1 a)]
+
+instance
+  (ToGenericSyntaxTree t, Traversable f, Foldable l) =>
+  GToMemberList (Rec0 (l (t f a))) f a
+  where
+  gToMemberList _ as = toGenericSyntaxTree <$> Data.Foldable.toList (unK1 as)
+
+instance GToMemberList (Rec0 a) f a where
+  gToMemberList _ _ = []
+
+instance GToMemberList r f a => GToMemberList (M1 i c r) f a where
+  gToMemberList n (M1 r) = gToMemberList n r
+
+instance (ToGenericSyntaxTree r, Traversable f) => GToGenericSyntaxTree (Rec0 (r f a)) f a where
+  gToGenericSyntaxTree k1 = toGenericSyntaxTree $ unK1 k1
+
+instance
+  (GToMemberList r f a, KnownSymbol name, GAnnot a r) =>
+  (GToGenericSyntaxTree (C1 ('MetaCons name _f _b) r)) f a
+  where
+  gToGenericSyntaxTree c =
+    SyntaxTreeObject (symbolVal (nameProxy c)) (gToMemberList 0 (unM1 c)) (gannot c)
+    where
+      nameProxy :: C1 ('MetaCons name _f _b) r x -> Proxy name
+      nameProxy _ = Proxy
+
+instance
+  (GToGenericSyntaxTree l f a, GToGenericSyntaxTree r f a) =>
+  (GToGenericSyntaxTree (l :+: r) f a)
+  where
+  gToGenericSyntaxTree (L1 l) = gToGenericSyntaxTree l
+  gToGenericSyntaxTree (R1 r) = gToGenericSyntaxTree r
+
+instance (GToGenericSyntaxTree r f a) => (GToGenericSyntaxTree (M1 i c r) f a) where
+  gToGenericSyntaxTree (M1 r) = gToGenericSyntaxTree r
+
+-- deriving instance (ToGenericSyntaxTree (Test stage))
+
+deriving instance (ToGenericSyntaxTree (Identifier stage))
+
+deriving instance (ToGenericSyntaxTree (FiddleUnit stage))
+
+deriving instance (ToGenericSyntaxTree (FiddleDecl stage))
+
+instance ToGenericSyntaxTree (ObjType stage) where
+  toGenericSyntaxTree = \case
+    (AnonymousObjType body annot) ->
+      SyntaxTreeDeferred $
+        fmap
+          ( \body' ->
+              SyntaxTreeObject
+                "AnonymousObjType"
+                [toGenericSyntaxTree body']
+                annot
+          )
+          body
+    (ArrayObjType arr expr annot) ->
+      SyntaxTreeObject
+        "ArrayObjType"
+        [toGenericSyntaxTree arr, toGenericSyntaxTree expr]
+        annot
+    (ReferencedObjType ident a) ->
+      SyntaxTreeObject "ReferencedObjType" [toGenericSyntaxTree ident] a
+
+deriving instance (ToGenericSyntaxTree (ObjTypeBody stage))
+
+deriving instance (ToGenericSyntaxTree (ObjTypeDecl stage))
+
+deriving instance (ToGenericSyntaxTreeValue ModifierKeyword)
+
+deriving instance (ToGenericSyntaxTree (Modifier stage))
+
+deriving instance (ToGenericSyntaxTree (DeferredRegisterBody stage))
+
+deriving instance (ToGenericSyntaxTree (RegisterBody stage))
+
+deriving instance (ToGenericSyntaxTree (RegisterBitsDecl stage))
+
+instance ToGenericSyntaxTree (RegisterBitsTypeRef stage) where
+  toGenericSyntaxTree = \case
+    (RegisterBitsArray ref exp a) ->
+      SyntaxTreeObject
+        "RegisterBitsArray"
+        [toGenericSyntaxTree ref, toGenericSyntaxTree exp]
+        a
+    (RegisterBitsReference i a) ->
+      SyntaxTreeObject "RegisterBitsReference" [toGenericSyntaxTree i] a
+    (RegisterBitsAnonymousType t a) ->
+      SyntaxTreeObject "RegisterBitsAnonymousType " [toGenericSyntaxTree t] a
+    (RegisterBitsJustBits t a) ->
+      SyntaxTreeObject "RegisterBitsJustBits " [toGenericSyntaxTree t] a
+
+deriving instance (ToGenericSyntaxTree (AnonymousBitsType stage))
+
+deriving instance (ToGenericSyntaxTree (BitType stage))
+
+deriving instance (ToGenericSyntaxTree (EnumBody stage))
+
+deriving instance (ToGenericSyntaxTree (EnumConstantDecl stage))
+
+deriving instance (ToGenericSyntaxTree (PackageBody stage))
+
+instance (ToGenericSyntaxTree (Expression stage)) where
+  toGenericSyntaxTree = \case
+    LitNum t a -> SyntaxTreeObject "LitNum" [SyntaxTreeValue (show t)] a
+    RealNum t a -> SyntaxTreeObject "RealNum" [SyntaxTreeValue (show t)] a
+    Var t a -> SyntaxTreeObject "LitNum" [toGenericSyntaxTree t] a