Fleshed out stage2 and made some big changes.

Delegated behavior of Compile monad to monad transformers MaybeT and RWS.
author: Josh Rahm <joshuarahm@gmail.com> 2024-08-21 17:18:35 -0600
committer: Josh Rahm <joshuarahm@gmail.com> 2024-08-21 17:18:35 -0600
commit: 21f879cf2ac5f51f827fe76c55915e56edc113b8 (patch)
tree: 78adb4cb69fec285cbb2fd82191596c97e3f18c9
parent: d6fae8c7de4bc952ba88f0c86cad9e8141eaf3df (diff)
download: fiddle-21f879cf2ac5f51f827fe76c55915e56edc113b8.tar.gz
fiddle-21f879cf2ac5f51f827fe76c55915e56edc113b8.tar.bz2
fiddle-21f879cf2ac5f51f827fe76c55915e56edc113b8.zip
11 files changed, 424 insertions, 211 deletions
diff --git a/package.yaml b/package.yaml
index 2ca3b73..2f78def 100644
--- a/package.yaml
+++ b/package.yaml
@@ -33,3 +33,4 @@ dependencies:
   - vector
   - bytestring
   - data-default
+  - transformers
diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs
index 61a637e..277ab24 100644
--- a/src/Language/Fiddle/Ast.hs
+++ b/src/Language/Fiddle/Ast.hs
@@ -9,45 +9,41 @@
 module Language.Fiddle.Ast where
 
 import Data.Functor.Identity
+import Data.Kind (Type)
 import Data.Proxy
 import Data.Text (Text)
 import Data.Traversable
+import Data.Typeable
 import GHC.Generics
+import GHC.TypeLits
+
+type family NumberType (a :: Stage) where
+  NumberType Stage1 = Text
+  NumberType Stage2 = Integer
+  NumberType Stage3 = Integer
 
 -- Stage of compilation. Parts of the AST maybe un unavailable with other stages
 -- as compilation simplifies the AST.
 data Stage = Stage1 | Stage2 | Stage3
+  deriving (Typeable)
+
+-- Root of the parse tree. Just contains a list of declarations.
+data FiddleUnit (stage :: Stage) (f :: Type -> Type) a where
+  FiddleUnit :: [FiddleDecl stage f a] -> a -> FiddleUnit stage f a
+  deriving (Generic, Annotated, Alter, Typeable)
 
 -- Just an identifier.
 data Identifier stage f a = Identifier !Text a
-  deriving (Generic, Annotated, Alter)
+  deriving (Generic, Annotated, Alter, Typeable)
 
 -- Expression.
 data Expression stage f a where
   -- Just a string. Parsing the number comes in stage2.
-  LitNum :: Text -> a -> Expression 'Stage1 f a
-  RealNum :: Integer -> a -> Expression 'Stage2 f a
+  LitNum :: NumberType stage -> a -> Expression stage f a
   Var :: Identifier stage f a -> a -> Expression stage f a
 
-instance Alter (Expression stage) where
-  alter ffn fn = \case
-    LitNum t a -> LitNum t <$> fn a
-    RealNum i a -> RealNum i <$> fn a
-    Var i a -> Var <$> alter ffn fn i <*> fn a
-
-instance Annotated (Expression stage) where
-  annot = \case
-    LitNum _ a -> a
-    RealNum _ a -> a
-    Var _ a -> a
-
--- Root of the parse tree. Just contains a list of declarations.
-data FiddleUnit (stage :: Stage) (f :: * -> *) a where
-  FiddleUnit :: [FiddleDecl stage f a] -> a -> FiddleUnit stage f a
-  deriving (Generic, Annotated, Alter)
-
 -- Top-level declarations.
-data FiddleDecl (stage :: Stage) (f :: * -> *) a where
+data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where
   {-
    - An option is a key/value pair.
    - option <ident> <ident>;
@@ -88,7 +84,11 @@ data FiddleDecl (stage :: Stage) (f :: * -> *) a where
     ObjType stage f a ->
     a ->
     FiddleDecl stage f a
-  deriving (Generic, Annotated, Alter)
+  deriving (Generic, Annotated, Alter, Typeable)
+
+data ObjTypeBody (stage :: Stage) (f :: Type -> Type) a where
+  ObjTypeBody :: [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a
+  deriving (Generic, Annotated, Alter, Typeable)
 
 data ObjType stage f a where
   -- { <body> }
@@ -99,29 +99,15 @@ data ObjType stage f a where
   ArrayObjType :: ObjType stage f a -> Expression stage f a -> a -> ObjType stage f a
   -- <identifier>
   ReferencedObjType :: Identifier stage f a -> a -> ObjType stage f a
-
-instance Alter (ObjType stage) where
-  alter ffn fn = \case
-    (AnonymousObjType b a) ->
-      AnonymousObjType <$> (ffn =<< mapM (alter ffn fn) b) <*> fn a
-    (ArrayObjType t e a) ->
-      ArrayObjType <$> alter ffn fn t <*> alter ffn fn e <*> fn a
-    (ReferencedObjType i a) ->
-      ReferencedObjType <$> alter ffn fn i <*> fn a
-
-instance Annotated (ObjType stage) where
-  annot = \case
-    (AnonymousObjType _ a) -> a
-    (ArrayObjType _ _ a) -> a
-    (ReferencedObjType _ a) -> a
-
-data ObjTypeBody (stage :: Stage) (f :: * -> *) a where
-  ObjTypeBody :: [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a
-  deriving (Generic, Annotated, Alter)
+  deriving (Typeable)
 
 data ObjTypeDecl stage f a where
   {- assert_pos(<expr>) -}
-  AssertPosStatement :: Expression stage f a -> a -> ObjTypeDecl stage f a
+  AssertPosStatement ::
+    (CmpNat (StageNumber stage) 3 ~ LT) =>
+    Expression stage f a ->
+    a ->
+    ObjTypeDecl stage f a
   {- reg <ident>(<expr>) : <regtype> -}
   RegisterDecl ::
     Maybe (Modifier stage f a) ->
@@ -130,24 +116,24 @@ data ObjTypeDecl stage f a where
     Maybe (RegisterBody stage f a) ->
     a ->
     ObjTypeDecl stage f a
-  deriving (Generic, Annotated, Alter)
+  deriving (Typeable)
 
 data Modifier stage f a where
   ModifierKeyword :: ModifierKeyword -> a -> Modifier stage f a
-  deriving (Generic, Annotated, Alter)
+  deriving (Generic, Annotated, Alter, Typeable)
 
-data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read)
+data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read, Typeable)
 
 data DeferredRegisterBody stage f a where
   DeferredRegisterBody ::
     [RegisterBitsDecl stage f a] ->
     a ->
     DeferredRegisterBody stage f a
-  deriving (Generic, Annotated, Alter)
+  deriving (Generic, Annotated, Alter, Typeable)
 
 data RegisterBody stage f a where
   RegisterBody :: f (DeferredRegisterBody stage f a) -> a -> RegisterBody stage f a
-  deriving (Generic, Annotated, Alter)
+  deriving (Generic, Annotated, Alter, Typeable)
 
 data RegisterBitsDecl stage f a where
   -- reserved(<expr>)
@@ -159,19 +145,7 @@ data RegisterBitsDecl stage f a where
     RegisterBitsTypeRef stage f a ->
     a ->
     RegisterBitsDecl stage f a
-  deriving (Generic, Annotated, Alter)
-
-data Test stage f a where
-  Test ::
-    Identifier stage f a ->
-    Identifier stage f a ->
-    Identifier stage f a ->
-    Identifier stage f a ->
-    Identifier stage f a ->
-    Identifier stage f a ->
-    a ->
-    Test stage f a
-  deriving (Generic)
+  deriving (Generic, Annotated, Alter, Typeable)
 
 data RegisterBitsTypeRef stage f a where
   -- <type>[<expr>]
@@ -186,7 +160,7 @@ data RegisterBitsTypeRef stage f a where
      Anonymous types are only allowed in stage1.
      Stage2 should de-anonymize these type. -}
   RegisterBitsAnonymousType ::
-    AnonymousBitsType stage f a ->
+    AnonymousBitsType Stage1 f a ->
     a ->
     RegisterBitsTypeRef 'Stage1 f a
   {- (<expr>)
@@ -198,6 +172,47 @@ data RegisterBitsTypeRef stage f a where
     a ->
     RegisterBitsTypeRef stage f a
 
+instance Alter (Expression stage) where
+  alter ffn fn = \case
+    LitNum t a -> LitNum t <$> fn a
+    Var i a -> Var <$> alter ffn fn i <*> fn a
+
+instance Annotated (Expression stage) where
+  annot = \case
+    LitNum _ a -> a
+    Var _ a -> a
+
+instance Alter (ObjTypeDecl stage) where
+  alter ffn fn = \case
+    (AssertPosStatement expr a) -> AssertPosStatement <$> alter ffn fn expr <*> fn a
+    (RegisterDecl mMod mIdent expr mBody a) ->
+      RegisterDecl
+        <$> mapM (alter ffn fn) mMod
+        <*> mapM (alter ffn fn) mIdent
+        <*> alter ffn fn expr
+        <*> mapM (alter ffn fn) mBody
+        <*> fn a
+
+instance Annotated (ObjTypeDecl stage) where
+  annot = \case
+    (AssertPosStatement _ a) -> a
+    (RegisterDecl _ _ _ _ a) -> a
+
+instance Alter (ObjType stage) where
+  alter ffn fn = \case
+    (AnonymousObjType b a) ->
+      AnonymousObjType <$> (ffn =<< mapM (alter ffn fn) b) <*> fn a
+    (ArrayObjType t e a) ->
+      ArrayObjType <$> alter ffn fn t <*> alter ffn fn e <*> fn a
+    (ReferencedObjType i a) ->
+      ReferencedObjType <$> alter ffn fn i <*> fn a
+
+instance Annotated (ObjType stage) where
+  annot = \case
+    (AnonymousObjType _ a) -> a
+    (ArrayObjType _ _ a) -> a
+    (ReferencedObjType _ a) -> a
+
 instance Alter (RegisterBitsTypeRef stage) where
   alter ffn fn = \case
     (RegisterBitsArray ref exp a) ->
@@ -218,10 +233,14 @@ instance Annotated (RegisterBitsTypeRef stage) where
 
 data AnonymousBitsType stage f a where
   -- enum(<expr>) { <body> }
-  AnonymousEnumBody :: Expression stage f a -> f (EnumBody stage f a) -> a -> AnonymousBitsType stage f a
-  deriving (Generic, Annotated, Alter)
+  AnonymousEnumBody ::
+    Expression stage f a ->
+    f (EnumBody stage f a) ->
+    a ->
+    AnonymousBitsType stage f a
+  deriving (Generic, Annotated, Alter, Typeable)
 
-data BitType (stage :: Stage) (f :: * -> *) a where
+data BitType (stage :: Stage) (f :: Type -> Type) a where
   -- enum(<expr>) { <body> }
   EnumBitType ::
     Expression stage f a ->
@@ -230,24 +249,24 @@ data BitType (stage :: Stage) (f :: * -> *) a where
     BitType stage f a
   -- (<expr>)
   RawBits :: Expression stage f a -> a -> BitType stage f a
-  deriving (Generic, Annotated, Alter)
+  deriving (Generic, Annotated, Alter, Typeable)
 
-data EnumBody (stage :: Stage) (f :: * -> *) a where
+data EnumBody (stage :: Stage) (f :: Type -> Type) a where
   -- <decl>,
   EnumBody :: [EnumConstantDecl stage f a] -> a -> EnumBody stage f a
-  deriving (Generic, Annotated, Alter)
+  deriving (Generic, Annotated, Alter, Typeable)
 
 data EnumConstantDecl stage f a where
   -- <ident> = <expr>
   EnumConstantDecl :: Identifier stage f a -> Expression stage f a -> a -> EnumConstantDecl stage f a
   -- reserved = <expr>
   EnumConstantReserved :: Expression stage f a -> a -> EnumConstantDecl stage f a
-  deriving (Generic, Annotated, Alter)
+  deriving (Generic, Annotated, Alter, Typeable)
 
-data PackageBody (stage :: Stage) (f :: * -> *) a where
+data PackageBody (stage :: Stage) (f :: Type -> Type) a where
   {- The body of a package -}
   PackageBody :: [FiddleDecl stage f a] -> a -> PackageBody stage f a
-  deriving (Generic, Annotated, Alter)
+  deriving (Generic, Annotated, Alter, Typeable)
 
 -- instance Alter (Modifier stage) where
 --   alter _ fn (ModifierKeyword m a) = ModifierKeyword m (fn a)
@@ -264,7 +283,7 @@ data PackageBody (stage :: Stage) (f :: * -> *) a where
 proxyOf :: t f a -> Proxy t
 proxyOf _ = Proxy
 
-class Annotated (t :: (* -> *) -> * -> *) where
+class Annotated (t :: (Type -> Type) -> Type -> Type) where
   annot :: t f a -> a
   default annot :: (Generic (t f a), GAnnot a (Rep (t f a))) => t f a -> a
   annot t = gannot (from t)
@@ -273,7 +292,7 @@ class GAnnot a r where
   gannot :: r x -> a
 
 instance GAnnot a (Rec0 a) where
-  gannot k1 = unK1 k1
+  gannot = unK1
 
 instance (GAnnot a r) => GAnnot a (l :*: r) where
   gannot (_ :*: r) = gannot r
@@ -285,7 +304,7 @@ instance (GAnnot a r, GAnnot a l) => GAnnot a (l :+: r) where
 instance (GAnnot a r) => GAnnot a (M1 i c r) where
   gannot (M1 a) = gannot a
 
-class Alter (t :: (* -> *) -> * -> *) where
+class Alter (t :: (Type -> Type) -> Type -> Type) where
   alter ::
     forall f1 f2 a1 a2 m.
     (Monad m, Traversable f1) =>
@@ -382,6 +401,11 @@ instance
   where
   galter proxy ffn fn (M1 a) = M1 <$> galter proxy ffn fn a
 
+type family StageNumber (s :: Stage) :: Natural where
+  StageNumber Stage1 = 1
+  StageNumber Stage2 = 2
+  StageNumber Stage3 = 3
+
 {--}
 squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a)
 squeeze = alter (fmap Identity) return
diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs
index 8d8d65c..b523a78 100644
--- a/src/Language/Fiddle/Compiler.hs
+++ b/src/Language/Fiddle/Compiler.hs
@@ -1,6 +1,9 @@
 module Language.Fiddle.Compiler where
 
+import Control.Monad (when)
+import Control.Monad.RWS (RWS, RWST, evalRWS, mapRWS, runRWS)
 import Control.Monad.State
+import Control.Monad.Trans.Maybe
 import Control.Monad.Writer
 import Data.Default
 import Language.Fiddle.Ast
@@ -12,65 +15,39 @@ data Level = Error | Warning | Info
 data Diagnostic = Diagnostic Level String SourceSpan
 
 -- Compilation monad. Has diagnostics. Optionally produces a value.
-newtype Compile s a = Compile (s -> (s, [Diagnostic], Maybe a))
+-- newtype Compile s a = Compile (s -> (s, [Diagnostic], Maybe a))
 
-instance Functor (Compile s) where
-  fmap fn (Compile cfn) = Compile $ \s ->
-    let (s', d', ma) = cfn s in (s, d', fmap fn ma)
+newtype Compile s a = Compile (MaybeT (RWS () [Diagnostic] s) a)
+  deriving (Functor, Applicative, Monad)
 
-instance Applicative (Compile s) where
-  (<*>) mfn ma = do
-    fn <- mfn
-    fn <$> ma
-
-  pure = return
-
-instance Monad (Compile s) where
-  return a = Compile (,[],Just a)
-
-  -- m a -> (a -> m b) -> m b
-  (>>=) (Compile cfn) fn = Compile $ \s ->
-    let (s', diags, ma) = cfn s
-     in case ma of
-          Nothing -> (s', diags, Nothing)
-          Just a ->
-            let (Compile cfn') = fn a
-                (s'', diags', mb) = cfn' s'
-             in (s'', diags ++ diags', mb)
+compilationFailure :: Compile s a
+compilationFailure = Compile $ MaybeT (return Nothing)
 
 instance MonadWriter [Diagnostic] (Compile s) where
-  tell diag = Compile (,diag,Just ())
-
-  listen (Compile fn) = Compile $ \s ->
-    let (s', diags, ma) = fn s in (s', diags, (,diags) <$> ma)
-
-  -- Not really "correctly" implemented, but I suspect this function will not be
-  -- used very much.
-  pass (Compile fn) = Compile $ \s ->
-    let (s', diags, mafn) = fn s
-     in case mafn of
-          Just (a, fn) -> (s', fn diags, Just a)
-          Nothing -> (s', diags, Nothing)
+  tell = Compile . tell
+  listen (Compile fn) = Compile $ listen fn
+  pass (Compile fn) = Compile $ pass fn
 
 instance MonadState s (Compile s) where
-  get = Compile $ \s -> (s, [], Just s)
-
-  put s = Compile $ const (s, [], Just ())
-
-hoistMaybe :: Maybe a -> Compile s a
-hoistMaybe ma = Compile (,[],ma)
+  get = Compile get
+  put s = Compile $ put s
+  state fn = Compile $ state fn
 
 -- Runs a sub-compilation routine with the given state, but discards the
 -- resulting state in favor of the original state.
-subCompile :: s' -> Compile s' a -> Compile s a
-subCompile s' (Compile fn) = Compile $ \s ->
-  let (_, diags, ma) = fn s' in (s, diags, ma)
+subCompile :: s' -> Compile s' a -> Compile s (s', a)
+subCompile s' (Compile mtrws) = Compile $ do
+  let (a, s, w) = runRWS (runMaybeT mtrws) () s'
+  tell w
+  MaybeT $ return $ fmap (s,) a
+
+-- mapMaybeT (mapRWS (\(a, _, w) -> (a, s', w))) mtrws
 
 -- Saves the state, runs the routine, then restores the state.
 pushState :: Compile s a -> Compile s a
 pushState cp = do
   s <- get
-  subCompile s cp
+  snd <$> subCompile s cp
 
 -- Runs a compilation routine. It produces diagnostics and maybe a result.
 -- Generally if the diagnostics contain an error, the result will be Nothing,
@@ -80,12 +57,15 @@ pushState cp = do
 -- from returning something even if the diagnostics contain errors, but it
 -- generally wouldn't make much sense for this to be the case.
 compile :: Compile s a -> s -> ([Diagnostic], Maybe a)
-compile (Compile fn) initState =
-  let (_, d, ma) = fn initState in (d, ma)
+compile (Compile fn) initState = do
+  let (a, _, w) = runRWS (runMaybeT fn) () initState in (w, a)
 
 compile_ :: (Default s) => Compile s a -> ([Diagnostic], Maybe a)
 compile_ c = compile c def
 
+hoistMaybe :: Maybe a -> Compile s a
+hoistMaybe = Compile . MaybeT . return
+
 newtype DiagnosticFormat = DiagnosticFormat (Diagnostic -> String)
 
 coloredFormat :: DiagnosticFormat
@@ -117,3 +97,9 @@ diagnosticToString (DiagnosticFormat f) = f
 printDiagnostic :: Diagnostic -> IO ()
 printDiagnostic d =
   putStrLn (diagnosticToString coloredFormat d)
+
+fromMayberOrFail :: SourceSpan -> String -> Maybe a -> Compile s a
+fromMayberOrFail sourceSpan err Nothing = do
+  tell [Diagnostic Error err sourceSpan]
+  compilationFailure
+fromMayberOrFail _ _ (Just a) = return a
diff --git a/src/Language/Fiddle/Compiler/Stage0.hs b/src/Language/Fiddle/Compiler/Stage0.hs
index d00d7cb..77c396e 100644
--- a/src/Language/Fiddle/Compiler/Stage0.hs
+++ b/src/Language/Fiddle/Compiler/Stage0.hs
@@ -20,7 +20,7 @@ toStage0 filePath text =
   case Language.Fiddle.Parser.parseFiddleText filePath text of
     Left pe -> do
       tell [parseErrorToDiagnostic pe]
-      hoistMaybe Nothing
+      compilationFailure
     Right a -> return a
 
 -- Gets the AST ready for Stage1 processing .This will report primarily
diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs
index ace5235..7a048fa 100644
--- a/src/Language/Fiddle/Compiler/Stage1.hs
+++ b/src/Language/Fiddle/Compiler/Stage1.hs
@@ -5,24 +5,31 @@
 
 module Language.Fiddle.Compiler.Stage1 (toStage2) where
 
-import Control.Monad.Identity (Identity(..))
-import Control.Monad.State (get, gets, put)
+import Control.Monad.Identity (Identity (..))
+import Control.Monad.State (get, gets, modify, put)
+import qualified Data.Char as Char
 import Data.List (intercalate)
 import Data.Text (Text)
+import qualified Data.Text as Text
 import Data.Type.Bool
+import Debug.Trace
 import GHC.Generics
 import GHC.TypeLits
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler
+import Language.Fiddle.Types
+import Text.Printf (printf)
 
-newtype Linkage = Linkage Text
+newtype Linkage = Linkage Text deriving (Show)
 
 newtype Path = Path [PathExpression]
 
 newtype PathExpression = PathExpression String
 
+type Annot = Commented SourceSpan
+
 joinPath :: Path -> String
-joinPath (Path l) = intercalate "_" (map (\(PathExpression s) -> s) l)
+joinPath (Path l) = intercalate "#" $ reverse (map (\(PathExpression s) -> s) l)
 
 -- Shorthand for Identity
 type I = Identity
@@ -40,22 +47,53 @@ class EasyStage2 t where
 instance EasyStage2 Identifier where
   toS2 (Identifier t a) = Identifier t a
 
+instance EasyStage2 Modifier where
+  toS2 (ModifierKeyword keyword annot) = ModifierKeyword keyword annot
+
 type M a = Compile (Stage2CompilerState a)
 
+internObjType :: Path -> ObjTypeBody Stage2 I a -> M a (Identifier Stage2 I a)
+internObjType path body =
+  let str = Text.pack $ joinPath path
+   in do
+        modify $ \(Stage2CompilerState objTypeBodies a) ->
+          Stage2CompilerState ((Linkage str, body) : objTypeBodies) a
+        return (Identifier str (annot body))
+
+internAnonymousBitsType :: Path -> AnonymousBitsType Stage2 I a -> M a (Identifier Stage2 I a)
+internAnonymousBitsType path anonymousBitsType =
+  let str = Text.pack $ joinPath path
+   in do
+        modify $ \(Stage2CompilerState a anonymousBitsTypes) ->
+          Stage2CompilerState a ((Linkage str, anonymousBitsType) : anonymousBitsTypes)
+        return (Identifier str (annot anonymousBitsType))
+
+traceState :: M a ()
+traceState = do
+  (Stage2CompilerState anonymousObjTypes anonymousBitsTypes) <- get
+  traceM $ printf "objtypes': %s\n" (show $ map fst anonymousObjTypes)
+  traceM $ printf "bittypes': %s\n" (show $ map fst anonymousBitsTypes)
+
 -- The second stage is a simplified version of the AST without anonymous
 -- declarations.
-toStage2 :: FiddleUnit Stage1 I a -> Compile () (FiddleUnit Stage2 I (Maybe a))
-toStage2 fa = toStage2' $ fmap Just fa
-  where
-    toStage2' (FiddleUnit decls annot) =
-      subCompile (Stage2CompilerState [] []) $
-        FiddleUnit <$> mapM (fiddleDeclToStage2 (Path [])) decls <*> pure annot
-
-reconfigureFiddleDecls :: Path -> [FiddleDecl Stage1 I a] -> M a [FiddleDecl Stage2 I a]
+toStage2 :: FiddleUnit Stage1 I Annot -> Compile () (FiddleUnit Stage2 I Annot)
+toStage2 (FiddleUnit decls annot) = do
+  (s, a) <-
+    subCompile (Stage2CompilerState [] []) $
+      FiddleUnit <$> reconfigureFiddleDecls (Path []) decls <*> pure annot
+  return a
+
+reconfigureFiddleDecls :: Path -> [FiddleDecl Stage1 I Annot] -> M Annot [FiddleDecl Stage2 I Annot]
 reconfigureFiddleDecls p decls = do
-  (Stage2CompilerState anonymousObjTypes anonymousBitsTypes, decls) <- pushState $ do
-    put (Stage2CompilerState [] [])
-    gets (,) <*> mapM (fiddleDeclToStage2 p) decls
+  -- (Stage2CompilerState anonymousObjTypes anonymousBitsTypes, decls) <- pushState $ do
+  --   put (Stage2CompilerState [] [])
+  --   gets (,) <*> mapM (fiddleDeclToStage2 p) decls
+
+  lastState <- get
+  put (Stage2CompilerState [] [])
+  decls <- mapM (fiddleDeclToStage2 p) decls
+  (Stage2CompilerState anonymousObjTypes anonymousBitsTypes) <- get
+  put lastState
 
   return $
     map resolveAnonymousObjType anonymousObjTypes
@@ -68,26 +106,142 @@ reconfigureFiddleDecls p decls = do
     resolveAnonymousBitsType (Linkage linkage, AnonymousEnumBody expr body a) =
       BitsDecl (Identifier linkage a) (EnumBitType expr body a) a
 
-fiddleDeclToStage2 :: Path -> FiddleDecl Stage1 I a -> M a (FiddleDecl Stage2 I a)
-fiddleDeclToStage2 path = \case
-  (OptionDecl i1 i2 a) -> return $ OptionDecl (toS2 i1) (toS2 i2) a
-  (PackageDecl i (Identity body) a) -> do
-    PackageDecl (toS2 i) <$> (Identity <$> packageBodyToStage2 path body) <*> pure a
-  (LocationDecl i expr a) -> LocationDecl (toS2 i) <$> toStage2Expr expr <*> pure a
-  (BitsDecl i typ a) -> return $ BitsDecl (toS2 i) undefined a
-  (ObjTypeDecl i body a) -> return $ ObjTypeDecl (toS2 i) undefined a
-  (ObjectDecl i expr typ a) ->
-    ObjectDecl (toS2 i) <$> toStage2Expr expr <*> pure undefined <*> pure a
-  _ -> undefined
-
-packageBodyToStage2 :: Path -> PackageBody Stage1 I a -> M a (PackageBody Stage2 I a)
+pushId :: Identifier stage f a -> Path -> Path
+pushId (Identifier str _) (Path lst) =
+  Path (PathExpression (Text.unpack str) : lst)
+
+fiddleDeclToStage2 :: Path -> FiddleDecl Stage1 I Annot -> M Annot (FiddleDecl Stage2 I Annot)
+fiddleDeclToStage2 path decl = do
+  case decl of
+    (OptionDecl i1 i2 a) -> return $ OptionDecl (toS2 i1) (toS2 i2) a
+    (PackageDecl i (Identity body) a) -> do
+      (PackageDecl (toS2 i) . Identity <$> packageBodyToStage2 (pushId i path) body) <*> pure a
+    (LocationDecl i expr a) -> LocationDecl (toS2 i) <$> toStage2Expr expr <*> pure a
+    (BitsDecl i typ a) -> BitsDecl (toS2 i) <$> bitsTypeToStage2 (pushId i path) typ <*> pure a
+    (ObjTypeDecl i body a) -> ObjTypeDecl (toS2 i) <$> mapM (objTypeBodyToStage2 (pushId i path)) body <*> pure a
+    (ObjectDecl i expr typ a) ->
+      ObjectDecl (toS2 i) <$> toStage2Expr expr <*> objectTypeToStage2 (pushId i path) typ <*> pure a
+
+bitsTypeToStage2 :: Path -> BitType Stage1 I Annot -> M Annot (BitType Stage2 I Annot)
+bitsTypeToStage2 path = \case
+  RawBits expr a -> RawBits <$> toStage2Expr expr <*> pure a
+  EnumBitType expr enumBody a ->
+    EnumBitType <$> toStage2Expr expr <*> mapM (enumBodyToStage2 path) enumBody <*> pure a
+
+enumBodyToStage2 :: Path -> EnumBody Stage1 I Annot -> M Annot (EnumBody Stage2 I Annot)
+enumBodyToStage2 path = \case
+  EnumBody constants a -> EnumBody <$> mapM (enumConstantToStage2 path) constants <*> pure a
+
+enumConstantToStage2 :: Path -> EnumConstantDecl Stage1 I Annot -> M Annot (EnumConstantDecl Stage2 I Annot)
+enumConstantToStage2 path = \case
+  EnumConstantDecl i e a -> EnumConstantDecl (toS2 i) <$> toStage2Expr e <*> pure a
+  EnumConstantReserved e a -> EnumConstantReserved <$> toStage2Expr e <*> pure a
+
+objTypeBodyToStage2 :: Path -> ObjTypeBody Stage1 I Annot -> M Annot (ObjTypeBody Stage2 I Annot)
+objTypeBodyToStage2 path (ObjTypeBody decls annot) = ObjTypeBody <$> mapM (objTypeDeclToStage2 path) decls <*> pure annot
+
+objTypeDeclToStage2 :: Path -> ObjTypeDecl Stage1 I Annot -> M Annot (ObjTypeDecl Stage2 I Annot)
+objTypeDeclToStage2 path = \case
+  (AssertPosStatement expr annot) -> AssertPosStatement <$> toStage2Expr expr <*> pure annot
+  (RegisterDecl maybeModifier maybeIdentifier expression maybeBody annot) ->
+    let path' = maybe path (`pushId` path) maybeIdentifier
+     in RegisterDecl
+          (fmap toS2 maybeModifier)
+          (fmap toS2 maybeIdentifier)
+          <$> toStage2Expr expression
+          <*> mapM (registerBodyToStage2 path') maybeBody
+          <*> pure annot
+
+registerBodyToStage2 :: Path -> RegisterBody Stage1 I Annot -> M Annot (RegisterBody Stage2 I Annot)
+registerBodyToStage2 path (RegisterBody (Identity (DeferredRegisterBody registerBitsDecl a1)) a2) =
+  RegisterBody . Identity
+    <$> ( DeferredRegisterBody
+            <$> mapM (registerBitsDeclToStage2 path) registerBitsDecl
+            <*> pure a1
+        )
+    <*> pure a2
+
+registerBitsDeclToStage2 :: Path -> RegisterBitsDecl Stage1 I Annot -> M Annot (RegisterBitsDecl Stage2 I Annot)
+registerBitsDeclToStage2 path = \case
+  ReservedBits expr a -> ReservedBits <$> toStage2Expr expr <*> pure a
+  DefinedBits maybeModifier identifier registerBitsTyperef annot ->
+    let path' = pushId identifier path
+     in ( DefinedBits
+            (fmap toS2 maybeModifier)
+            (toS2 identifier)
+            <$> registerBitsTypeRefToStage2 path' registerBitsTyperef
+            <*> pure annot
+        )
+
+registerBitsTypeRefToStage2 :: Path -> RegisterBitsTypeRef Stage1 I Annot -> M Annot (RegisterBitsTypeRef Stage2 I Annot)
+registerBitsTypeRefToStage2 path = \case
+  RegisterBitsArray typeref expr annot ->
+    RegisterBitsArray
+      <$> registerBitsTypeRefToStage2 path typeref
+      <*> toStage2Expr expr
+      <*> pure annot
+  RegisterBitsReference ident annot -> return (RegisterBitsReference (toS2 ident) annot)
+  RegisterBitsJustBits expr annot -> RegisterBitsJustBits <$> toStage2Expr expr <*> pure annot
+  RegisterBitsAnonymousType anonType annot -> do
+    ident <- internAnonymousBitsType path =<< anonymousBitsTypeToStage2 path anonType
+    return $ RegisterBitsReference ident annot
+
+anonymousBitsTypeToStage2 :: Path -> AnonymousBitsType Stage1 I Annot -> M Annot (AnonymousBitsType Stage2 I Annot)
+anonymousBitsTypeToStage2 path = \case
+  AnonymousEnumBody expr (Identity body) annot ->
+    AnonymousEnumBody
+      <$> toStage2Expr expr
+      <*> (Identity <$> enumBodyToStage2 path body)
+      <*> pure annot
+
+objectTypeToStage2 :: Path -> ObjType Stage1 I Annot -> M Annot (ObjType Stage2 I Annot)
+objectTypeToStage2 path = \case
+  (AnonymousObjType (Identity body) annot) -> do
+    body' <- objTypeBodyToStage2 path body
+    identifier <- internObjType path body'
+    return (ReferencedObjType identifier annot)
+  (ReferencedObjType ident annot) -> return $ ReferencedObjType (toS2 ident) annot
+  (ArrayObjType objType expr a) ->
+    ArrayObjType <$> objectTypeToStage2 path objType <*> toStage2Expr expr <*> pure a
+
+packageBodyToStage2 :: Path -> PackageBody Stage1 I Annot -> M Annot (PackageBody Stage2 I Annot)
 packageBodyToStage2 p (PackageBody decls a) =
   PackageBody <$> reconfigureFiddleDecls p decls <*> pure a
 
-toStage2Expr :: Expression Stage1 I a -> M a (Expression Stage2 I a)
+toStage2Expr :: Expression Stage1 I Annot -> M Annot (Expression Stage2 I Annot)
 toStage2Expr = \case
   (Var i a) -> return $ Var (toS2 i) a
-  (LitNum t a) -> RealNum <$> parseNum t <*> pure a
-
-parseNum :: Text -> M a Integer
-parseNum = undefined
+  (LitNum t a) -> LitNum <$> parseNum (unCommented a) t <*> pure a
+
+parseNum :: SourceSpan -> Text -> M a Integer
+parseNum span txt = fromMayberOrFail span "Unable to parse number" $
+  case Text.unpack (Text.take 2 txt) of
+    "0b" -> toNumWithRadix (Text.drop 2 txt) 2
+    "0x" -> toNumWithRadix (Text.drop 2 txt) 16
+    ('0' : _) -> toNumWithRadix (Text.tail txt) 8
+    _ -> toNumWithRadix txt 10
+  where
+    removeUnders :: Text -> Text
+    removeUnders = Text.replace (Text.pack "_") Text.empty
+
+    toNumWithRadix :: Text -> Int -> Maybe Integer
+    toNumWithRadix (removeUnders -> txt) (fromIntegral -> radix) =
+      Text.foldl
+        ( \mAcc x ->
+            mAcc >>= (\acc -> (acc * radix +) <$> digitToInt x radix)
+        )
+        (Just 0)
+        txt
+
+    digitToInt :: Char -> Integer -> Maybe Integer
+    digitToInt (Char.toLower -> ch) radix =
+      let a
+            | Char.isDigit ch = Just (Char.ord ch - Char.ord '0')
+            | ch >= 'a' && ch <= 'f' = Just $ (Char.ord ch - Char.ord 'a') + 10
+            | otherwise = Nothing
+       in a
+            >>= ( \a' ->
+                    if a' >= fromIntegral radix
+                      then Nothing
+                      else Just (fromIntegral a')
+                )
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
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index c9c3c86..dc479d1 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -7,6 +7,7 @@ module Language.Fiddle.Parser
   )
 where
 
+import Data.Kind (Type)
 import Data.Functor.Identity
 import Data.Text (Text)
 import qualified Data.Text
@@ -26,7 +27,7 @@ type P = ParsecT S () Identity
 
 type A = Commented SourceSpan
 
-type Pa (a :: Stage -> (* -> *) -> * -> *) = P (a 'Stage1 F (Commented SourceSpan))
+type Pa (a :: Stage -> (Type -> Type) -> Type -> Type) = P (a 'Stage1 F (Commented SourceSpan))
 
 comment :: P Comment
 comment =
diff --git a/src/Language/Fiddle/Types.hs b/src/Language/Fiddle/Types.hs
index 507b8cf..0f3b5b1 100644
--- a/src/Language/Fiddle/Types.hs
+++ b/src/Language/Fiddle/Types.hs
@@ -12,5 +12,5 @@ data SourceSpan = SourceSpan
   }
   deriving (Eq, Ord, Show)
 
-data Commented a = Commented ![Comment] !a
+data Commented a = Commented { comments :: ![Comment], unCommented :: !a }
    deriving (Show)
diff --git a/src/Main.hs b/src/Main.hs
index 92e9a1d..9330df5 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -9,6 +9,7 @@ import GHC.IO.Exception (ExitCode (ExitFailure))
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler (coloredFormat, compile_, printDiagnostic)
 import Language.Fiddle.Compiler.Stage0
+import Language.Fiddle.Compiler.Stage1
 import Language.Fiddle.GenericTree (ToGenericSyntaxTree (toGenericSyntaxTree))
 import qualified Language.Fiddle.Parser
 import qualified Language.Fiddle.Tokenizer
@@ -22,11 +23,10 @@ main = do
   case argv of
     [filePath] -> do
       text <- Data.Text.IO.readFile filePath
-      let (diags, ma) = compile_ $ toStage1 =<< toStage0 filePath text
+      let (diags, ma) = compile_ $ toStage2 =<< toStage1 =<< toStage0 filePath text
       forM_ diags printDiagnostic
       case ma of
         Just ast -> do
-          putStrLn "\x1b[1;32mCompilation Succeeded:\x1b[0m"
           putStrLn $ BL.unpack $ encode $ toGenericSyntaxTree ast
         Nothing -> do
           putStrLn "\x1b[1;31mCompilation Failed\x1b[0m"
diff --git a/stack.yaml b/stack.yaml
index b6e406d..c01ba0c 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-18.15
+resolver: lts-22.33
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
diff --git a/vim/syntax/fiddle.vim b/vim/syntax/fiddle.vim
index 01e9d04..22341a5 100644
--- a/vim/syntax/fiddle.vim
+++ b/vim/syntax/fiddle.vim
@@ -13,7 +13,7 @@ syn match FiddleIdent +[A-Za-z0-9_]\++ contained
 syn match FiddleComment +\/\/.*$+
 syn region FiddleDocComment start=+/\*\*+ end=+*/+
 
-syn match FiddleNumber +[0-9_]\+\([xb]\)\@!\|0x[0-9A-Fa-f_]\+\|0b[01]\++
+syn match FiddleNumber +[0-9_]\+\([xb]\)\@!\|0x[0-9A-Fa-f][0-9A-Fa-f_]*\|0b[01]\++
 
 hi! link FiddleContainedType Type
 hi! link FiddleModifier StorageClass
author	Josh Rahm <joshuarahm@gmail.com>	2024-08-21 17:18:35 -0600
committer	Josh Rahm <joshuarahm@gmail.com>	2024-08-21 17:18:35 -0600
commit	21f879cf2ac5f51f827fe76c55915e56edc113b8 (patch)
tree	78adb4cb69fec285cbb2fd82191596c97e3f18c9
parent	d6fae8c7de4bc952ba88f0c86cad9e8141eaf3df (diff)
download	fiddle-21f879cf2ac5f51f827fe76c55915e56edc113b8.tar.gz fiddle-21f879cf2ac5f51f827fe76c55915e56edc113b8.tar.bz2 fiddle-21f879cf2ac5f51f827fe76c55915e56edc113b8.zip