Fleshed out stage2 and made some big changes.

Delegated behavior of Compile monad to monad transformers MaybeT and
RWS.

1 files changed, 98 insertions, 51 deletions

diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index 21cfa68..b17954f 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -15,29 +16,58 @@ import Data.Aeson.Encoding (text)
 import Data.Aeson.Types as Aeson
 import qualified Data.Foldable
 import Data.Functor.Classes (Show1, liftShowsPrec)
+import Data.Kind (Type)
 import Data.Proxy
 import qualified Data.Text
+import Data.Typeable
 import qualified Data.Vector
 import GHC.Generics
 import GHC.TypeLits (KnownSymbol, symbolVal)
 import Language.Fiddle.Ast
+import Language.Fiddle.Types
+import Text.Parsec.Pos
 import Text.Printf (printf)
 
+type Context stage = (Show (NumberType stage), Typeable stage)
+
 data GenericSyntaxTree f a where
   {- GenericSyntaxtTree with a name and children. -}
   SyntaxTreeObject ::
+    forall a f tree.
+    (Typeable tree) =>
     String ->
     [GenericSyntaxTree f a] ->
     a ->
+    tree ->
     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
+instance ToJSON Comment where
+  toJSON (NormalComment str) = object ["normal" .= str]
+  toJSON (DocComment str) = object ["doc" .= str]
+
+instance (ToJSON a) => ToJSON (Commented a) where
+  toJSON (Commented comment a) =
+    object ["comment" .= comment, "annot" .= a]
+
+instance ToJSON SourceSpan where
+  toJSON (SourceSpan start end) =
+    object ["start" .= toJSON start, "end" .= toJSON end]
+
+instance ToJSON SourcePos where
+  toJSON sourcePos =
+    object
+      [ "name" .= sourceName sourcePos,
+        "row" .= sourceLine sourcePos,
+        "col" .= sourceColumn sourcePos
+      ]
+
+instance (Foldable f, ToJSON a) => ToJSON (GenericSyntaxTree f a) where
   toJSON = \case
-    (SyntaxTreeObject typ membs a) ->
-      object ["_type" .= typ, "_members" .= membs, "_annot" .= show a]
+    (SyntaxTreeObject typ membs a t) ->
+      object ["_type" .= show (typeOf t), "_con" .= typ, "_members" .= membs, "_annot" .= a]
     (SyntaxTreeList l) ->
       Array $ Data.Vector.fromList $ map toJSON l
     (SyntaxTreeDeferred fdef) ->
@@ -45,8 +75,8 @@ instance (Foldable f, Show a) => ToJSON (GenericSyntaxTree f a) where
     (SyntaxTreeValue s) -> String (Data.Text.pack s)
 
   toEncoding = \case
-    (SyntaxTreeObject typ membs a) ->
-      pairs $ "_type" .= typ <> "_members" .= membs <> "_annot" .= show a
+    (SyntaxTreeObject typ membs a t) ->
+      pairs $ "_type" .= show (typeOf t) <> "_con" .= typ <> "_members" .= membs <> "_annot" .= a
     (SyntaxTreeList l) ->
       foldable $ map toJSON l
     (SyntaxTreeDeferred fdef) ->
@@ -62,16 +92,18 @@ class ToGenericSyntaxTreeValue v where
 instance ToGenericSyntaxTreeValue Data.Text.Text where
   toGenericSyntaxTreeValue = SyntaxTreeValue . Data.Text.unpack
 
-class ToGenericSyntaxTree (t :: (* -> *) -> * -> *) where
-  toGenericSyntaxTree :: (Traversable f) => t f a -> GenericSyntaxTree f a
+type GenericContext t f a = (Traversable f, ToGenericSyntaxTree t, Typeable t, Typeable f, Typeable a)
+
+class ToGenericSyntaxTree (t :: (Type -> Type) -> Type -> Type) where
+  toGenericSyntaxTree :: (Traversable f, Typeable f, Typeable t, Typeable a) => t f a -> GenericSyntaxTree f a
   default toGenericSyntaxTree ::
-    (Generic (t f a), (GToGenericSyntaxTree (Rep (t f a)) f a), (Traversable f)) =>
+    (GenericContext t f a, Generic (t f a), (GToGenericSyntaxTree (Rep (t f a)) f a)) =>
     t f a ->
     GenericSyntaxTree f a
-  toGenericSyntaxTree = gToGenericSyntaxTree . from
+  toGenericSyntaxTree t = gToGenericSyntaxTree t (from t)
 
 class GToGenericSyntaxTree r f a where
-  gToGenericSyntaxTree :: r x -> GenericSyntaxTree f a
+  gToGenericSyntaxTree :: (Typeable t) => t -> r x -> GenericSyntaxTree f a
 
 class GToMemberList r f a where
   gToMemberList :: Int -> r x -> [GenericSyntaxTree f a]
@@ -80,16 +112,16 @@ instance (ToGenericSyntaxTreeValue v) => GToMemberList (Rec0 v) f a where
   gToMemberList _ = (: []) . toGenericSyntaxTreeValue . unK1
 
 instance
-  (Traversable f, ToGenericSyntaxTree r) =>
+  (GenericContext r f a) =>
   GToGenericSyntaxTree (Rec0 (f (r f a))) f a
   where
-  gToGenericSyntaxTree k1 = SyntaxTreeDeferred (toGenericSyntaxTree <$> unK1 k1)
+  gToGenericSyntaxTree _ k1 = SyntaxTreeDeferred (toGenericSyntaxTree <$> unK1 k1)
 
 instance
-  (Traversable f, Traversable f1, ToGenericSyntaxTree r) =>
+  (GenericContext r f a, Traversable f1) =>
   GToGenericSyntaxTree (Rec0 (f1 (r f a))) f a
   where
-  gToGenericSyntaxTree k1 =
+  gToGenericSyntaxTree _ k1 =
     SyntaxTreeList (Data.Foldable.toList $ toGenericSyntaxTree <$> unK1 k1)
 
 instance
@@ -100,11 +132,11 @@ instance
     where
       l1 = gToMemberList n l
 
-instance (ToGenericSyntaxTree t, Traversable f) => GToMemberList (Rec0 (t f a)) f a where
+instance (GenericContext t f a) => GToMemberList (Rec0 (t f a)) f a where
   gToMemberList _ a = [toGenericSyntaxTree (unK1 a)]
 
 instance
-  (ToGenericSyntaxTree t, Traversable f, Foldable l) =>
+  (GenericContext t f a, Foldable l) =>
   GToMemberList (Rec0 (l (t f a))) f a
   where
   gToMemberList _ as = toGenericSyntaxTree <$> Data.Foldable.toList (unK1 as)
@@ -112,18 +144,18 @@ instance
 instance GToMemberList (Rec0 a) f a where
   gToMemberList _ _ = []
 
-instance GToMemberList r f a => GToMemberList (M1 i c r) f a where
+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 (GenericContext r f a) => 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)
+  gToGenericSyntaxTree t c =
+    SyntaxTreeObject (symbolVal (nameProxy c)) (gToMemberList 0 (unM1 c)) (gannot c) t
     where
       nameProxy :: C1 ('MetaCons name _f _b) r x -> Proxy name
       nameProxy _ = Proxy
@@ -132,22 +164,22 @@ 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
+  gToGenericSyntaxTree t (L1 l) = gToGenericSyntaxTree t l
+  gToGenericSyntaxTree t (R1 r) = gToGenericSyntaxTree t r
 
 instance (GToGenericSyntaxTree r f a) => (GToGenericSyntaxTree (M1 i c r) f a) where
-  gToGenericSyntaxTree (M1 r) = gToGenericSyntaxTree r
+  gToGenericSyntaxTree t (M1 r) = gToGenericSyntaxTree t r
 
 -- deriving instance (ToGenericSyntaxTree (Test stage))
 
-deriving instance (ToGenericSyntaxTree (Identifier stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (Identifier stage))
 
-deriving instance (ToGenericSyntaxTree (FiddleUnit stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleUnit stage))
 
-deriving instance (ToGenericSyntaxTree (FiddleDecl stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleDecl stage))
 
-instance ToGenericSyntaxTree (ObjType stage) where
-  toGenericSyntaxTree = \case
+instance (Context stage) => ToGenericSyntaxTree (ObjType stage) where
+  toGenericSyntaxTree t = case t of
     (AnonymousObjType body annot) ->
       SyntaxTreeDeferred $
         fmap
@@ -156,6 +188,7 @@ instance ToGenericSyntaxTree (ObjType stage) where
                 "AnonymousObjType"
                 [toGenericSyntaxTree body']
                 annot
+                body'
           )
           body
     (ArrayObjType arr expr annot) ->
@@ -163,49 +196,63 @@ instance ToGenericSyntaxTree (ObjType stage) where
         "ArrayObjType"
         [toGenericSyntaxTree arr, toGenericSyntaxTree expr]
         annot
+        t
     (ReferencedObjType ident a) ->
-      SyntaxTreeObject "ReferencedObjType" [toGenericSyntaxTree ident] a
+      SyntaxTreeObject "ReferencedObjType" [toGenericSyntaxTree ident] a t
 
-deriving instance (ToGenericSyntaxTree (ObjTypeBody stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (ObjTypeBody stage))
 
-deriving instance (ToGenericSyntaxTree (ObjTypeDecl stage))
+instance (Context stage) => (ToGenericSyntaxTree (ObjTypeDecl stage)) where
+  toGenericSyntaxTree t = case t of
+    (AssertPosStatement expr a) ->
+      SyntaxTreeObject "AssertPosStatement" [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 (ToGenericSyntaxTreeValue ModifierKeyword)
 
-deriving instance (ToGenericSyntaxTree (Modifier stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (Modifier stage))
 
-deriving instance (ToGenericSyntaxTree (DeferredRegisterBody stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (DeferredRegisterBody stage))
 
-deriving instance (ToGenericSyntaxTree (RegisterBody stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (RegisterBody stage))
 
-deriving instance (ToGenericSyntaxTree (RegisterBitsDecl stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (RegisterBitsDecl stage))
 
-instance ToGenericSyntaxTree (RegisterBitsTypeRef stage) where
-  toGenericSyntaxTree = \case
+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
+      SyntaxTreeObject "RegisterBitsReference" [toGenericSyntaxTree i] a t
     (RegisterBitsAnonymousType t a) ->
-      SyntaxTreeObject "RegisterBitsAnonymousType " [toGenericSyntaxTree t] a
+      SyntaxTreeObject "RegisterBitsAnonymousType " [toGenericSyntaxTree t] a t
     (RegisterBitsJustBits t a) ->
-      SyntaxTreeObject "RegisterBitsJustBits " [toGenericSyntaxTree t] a
+      SyntaxTreeObject "RegisterBitsJustBits " [toGenericSyntaxTree t] a t
 
-deriving instance (ToGenericSyntaxTree (AnonymousBitsType stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (AnonymousBitsType stage))
 
-deriving instance (ToGenericSyntaxTree (BitType stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (BitType stage))
 
-deriving instance (ToGenericSyntaxTree (EnumBody stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (EnumBody stage))
 
-deriving instance (ToGenericSyntaxTree (EnumConstantDecl stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (EnumConstantDecl stage))
 
-deriving instance (ToGenericSyntaxTree (PackageBody stage))
+deriving instance (Context stage) => (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
+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