Implement qualification.

Big change. Implements qualification, which separates the qualification
concerns from the ConsistencyCheck phase.

I'm getting close to implementing a backend.

14 files changed, 836 insertions, 744 deletions

diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs
index a6ea87a..f5fbafe 100644
--- a/src/Language/Fiddle/Ast.hs
+++ b/src/Language/Fiddle/Ast.hs
@@ -8,3 +8,4 @@ import Language.Fiddle.Ast.Internal.Instances as X
 import Language.Fiddle.Ast.Internal.Kinds as X
 import Language.Fiddle.Ast.Internal.Stage as X
 import Language.Fiddle.Ast.Internal.SyntaxTree as X
+import Language.Fiddle.Ast.Internal.Util as X
diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs
index 232d5c0..aaa20b8 100644
--- a/src/Language/Fiddle/Ast/Internal/Instances.hs
+++ b/src/Language/Fiddle/Ast/Internal/Instances.hs
@@ -120,8 +120,8 @@ class
       stage
       ( t
           (StageAfter stage) -- The next stage in the pipeline
-          (StageFunctor stage) -- The functor associated with the next stage
-          (StageAnnotation stage) -- Annotation type for the next stage
+          (StageFunctor stage) -- The functor associated with this stage
+          (StageAnnotation stage) -- Annotation type for this stage
       )
 
   -- | Default implementation of 'advanceStage' using generics. This leverages
@@ -311,6 +311,12 @@ instance
     K1 <$> ffn newK
 
 instance
+  (Traversable f1) =>
+  GAlter t f1 f2 a1 a2 (Rec0 (f1 x)) (Rec0 (f2 x))
+  where
+  galter _ ffn _ (K1 k) = K1 <$> ffn k
+
+instance
   ( GAlter t f1 f2 a1 a2 l1 l2,
     GAlter t f1 f2 a1 a2 r1 r2
   ) =>
diff --git a/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs b/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs
index d80963d..221dd5b 100644
--- a/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs
+++ b/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs
@@ -1,8 +1,16 @@
-module Language.Fiddle.Ast.Internal.Instances.Walk (Walk (..), GWalk (..)) where
+module Language.Fiddle.Ast.Internal.Instances.Walk (Walk (..), GWalk (..), walk_) where
 
 import Data.Typeable
 import GHC.Generics
 
+-- | Like walk, but assumes no local state.
+walk_ ::
+  (Monad m, Traversable f, Typeable f, Typeable a, Walk t) =>
+  (forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> m ()) ->
+  t f a ->
+  m ()
+walk_ fn t = walk (\t _ -> fn t) t ()
+
 class (Typeable t) => Walk t where
   walk ::
     (Monad m, Traversable f, Typeable f, Typeable a) =>
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 8e3cd6c..73c4303 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -12,6 +12,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     ImportInterface,
     FiddleUnitInterface,
     QualificationMetadata,
+    CommonQualificationData (..),
     -- Witness Types
     Witness (..),
     WitnessType,
@@ -48,18 +49,13 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     mapDirectedM,
     asDirected,
     undirected,
-    -- Utility Functions
-    squeeze,
-    nameToList,
   )
 where
 
 import Control.Monad (forM_)
-import Data.Functor.Identity
 import Data.Kind (Type)
 import Data.List.NonEmpty hiding (map)
 import Data.Text (Text)
-import qualified Data.Text as Text
 import Data.Type.Bool
 import Data.Typeable
 import Data.Void (Void)
@@ -67,11 +63,11 @@ import GHC.Generics
 import Language.Fiddle.Ast.Internal.Instances
 import Language.Fiddle.Ast.Internal.Kinds
 import Language.Fiddle.Ast.Internal.Stage
-import Language.Fiddle.Internal.UnitInterface (UnitInterface)
+import Language.Fiddle.Internal.UnitInterface
 
 -- | Common data for each qualified element.
-newtype CommonQualifcationData
-  = CommonQualifcationData
+newtype CommonQualificationData
+  = CommonQualificationData
   { -- The fully qualified path to this qualified element.
     fullyQualifiedPath :: [String]
   }
@@ -79,7 +75,7 @@ newtype CommonQualifcationData
 
 type family QualificationMetadata stage t where
   QualificationMetadata stage t =
-    If (stage < Qualified) () (CommonQualifcationData, t)
+    If (stage < Qualified) () t
 
 -- | The type attached to import statements which describe the imported file's
 -- unit interface
@@ -278,7 +274,7 @@ data Expression (s :: Stage) :: SynTree where
   -- | A variable reference.
   Var ::
     { -- | The identifier of the variable.
-      varIdentifier :: Identifier f a,
+      varIdentifier :: Name f a,
       -- | Annotation for the variable.
       varAnnot :: a
     } ->
@@ -348,7 +344,8 @@ data FiddleDecl :: StagedSynTree where
   -- | A package declaration.
   PackageDecl ::
     { -- | Qualification metadata about this package statement.
-      packageQualificationMetadata :: QualificationMetadata stage (),
+      packageQualificationMetadata ::
+        f (QualificationMetadata stage ExportedPackageDecl),
       -- | The package name.
       packageName :: Name f a,
       -- | The body of the package.
@@ -360,7 +357,8 @@ data FiddleDecl :: StagedSynTree where
   -- | A location declaration in the form 'location <identifier> = <expr>'.
   LocationDecl ::
     { -- | qualified metadata about this location.
-      locationQualificationMetadata :: QualificationMetadata stage (),
+      locationQualificationMetadata ::
+        f (QualificationMetadata stage ExportedLocationDecl),
       -- | The location identifier.
       locationIdent :: Identifier f a,
       -- | The associated expression.
@@ -372,7 +370,7 @@ data FiddleDecl :: StagedSynTree where
   -- | A bits declaration in the form 'bits <identifier> : <type>'.
   BitsDecl ::
     { -- | Qualification metadata about this "bits" declaration.
-      bitsQualificationMetadata :: QualificationMetadata stage (),
+      bitsQualificationMetadata :: f (QualificationMetadata stage ExportedBitsDecl),
       -- | The identifier of the bits.
       bitsIdent :: Identifier f a,
       -- | The type of the bits.
@@ -384,7 +382,7 @@ data FiddleDecl :: StagedSynTree where
   -- | An object type declaration.
   ObjTypeDecl ::
     { -- | Qualification metadata about this object type.
-      objTypeQualificationMetadata :: QualificationMetadata stage (),
+      objTypeQualificationMetadata :: f (QualificationMetadata stage ExportedTypeDecl),
       -- | The identifier of the object type.
       objTypeIdent :: Identifier f a,
       -- | The body of the object type.
@@ -396,7 +394,7 @@ data FiddleDecl :: StagedSynTree where
   -- | An object declaration in the form 'object <ident> at <expr> : <type>'.
   ObjectDecl ::
     { -- | Qualification metadata about this object.
-      objectQualificationMetadata :: QualificationMetadata stage (),
+      objectQualificationMetadata :: f (QualificationMetadata stage ExportedObjectDecl),
       -- | The identifier of the object.
       objectIdent :: Identifier f a,
       -- | The location expression.
@@ -448,7 +446,7 @@ data ObjType stage f a where
     ObjType stage f a
   -- | A reference to an existing type by name.
   ReferencedObjType ::
-    { refQualificationMetadata :: QualificationMetadata stage (),
+    { refQualificationMetadata :: f (QualificationMetadata stage ExportedTypeDecl),
       -- | The name of the referenced type.
       refName :: Name f a,
       -- | Annotation for the referenced type.
@@ -609,7 +607,7 @@ data RegisterBitsTypeRef stage f a where
   -- | A reference to another type by name.
   RegisterBitsReference ::
     { -- | Qualification metadata about this Bits reference.
-      bitsRefQualificationMetadata :: QualificationMetadata stage (),
+      bitsRefQualificationMetadata :: f (QualificationMetadata stage ExportedBitsDecl),
       -- | The name of the referenced type.
       bitsRefName :: Name f a,
       -- | Annotation for the reference.
@@ -714,9 +712,3 @@ data PackageBody (stage :: Stage) (f :: Type -> Type) a where
     } ->
     PackageBody stage f a
   deriving (Generic, Annotated, Typeable, Alter, Walk)
-
-squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a)
-squeeze = alter (fmap Identity) return
-
-nameToList :: Name f a -> [String]
-nameToList (Name ids _) = map (Text.unpack . identifierName) (toList ids)
diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs
index c029765..049d533 100644
--- a/src/Language/Fiddle/Compiler.hs
+++ b/src/Language/Fiddle/Compiler.hs
@@ -6,6 +6,7 @@ module Language.Fiddle.Compiler where
 
 import Control.Arrow
 import Control.Monad (when)
+import Control.Monad.Identity (Identity)
 import Control.Monad.RWS
 import Control.Monad.Trans.Maybe
 import Control.Monad.Writer
@@ -21,6 +22,15 @@ data Level = Error | Warning | Info
 
 data Diagnostic = Diagnostic Level String SourceSpan
 
+emitDiagnosticError :: String -> Commented SourceSpan -> Compile a ()
+emitDiagnosticError str a = tell [Diagnostic Error str (unCommented a)]
+
+emitDiagnosticWarning :: String -> Commented SourceSpan -> Compile a ()
+emitDiagnosticWarning str a = tell [Diagnostic Warning str (unCommented a)]
+
+emitDiagnosticInfo :: String -> Commented SourceSpan -> Compile a ()
+emitDiagnosticInfo str a = tell [Diagnostic Info str (unCommented a)]
+
 newtype Compile s a = Compile (MaybeT (RWS () [Diagnostic] s) a)
   deriving newtype (Functor, Applicative, Monad)
 
@@ -103,13 +113,13 @@ pureCompilationPhase ::
   (CompilationStage stageFrom) =>
   ( FiddleUnit
       stageFrom
-      (StageFunctor stageFrom)
+      Identity
       (StageAnnotation stageFrom) ->
     Compile
       ()
       ( FiddleUnit
           stageTo
-          (StageFunctor stageTo)
+          Identity
           (StageAnnotation stageTo)
       )
   ) ->
@@ -138,7 +148,7 @@ data CompilationPhase stageFrom stageTo where
       -- only time a side effect may be performed.
       ioAction ::
         privateFlags ->
-        TreeType FiddleUnit Parsed ->
+        FiddleUnit Parsed Identity (StageAnnotation Parsed) ->
         IO ([Diagnostic], Maybe privateState),
       -- | 'nextStage' is the function that transforms a 'FiddleUnit' from
       -- the current stage ('stageFrom') to the next stage ('stageTo'). It
@@ -149,13 +159,13 @@ data CompilationPhase stageFrom stageTo where
         privateState ->
         FiddleUnit
           stageFrom
-          (StageFunctor stageFrom)
+          Identity
           (StageAnnotation stageFrom) ->
         Compile
           ()
           ( FiddleUnit
               stageTo
-              (StageFunctor stageTo)
+              Identity
               (StageAnnotation stageTo)
           )
     } ->
@@ -198,11 +208,11 @@ thenPhase
 execCompilationPipelineWithCmdline ::
   CompilationPhase Parsed s' ->
   Parser
-    ( FiddleUnit Parsed (StageFunctor Parsed) (StageAnnotation Parsed) ->
+    ( FiddleUnit Parsed Identity (StageAnnotation Parsed) ->
       IO
         ( [Diagnostic],
           Maybe
-            ( FiddleUnit s' (StageFunctor s') (StageAnnotation s')
+            ( FiddleUnit s' Identity (StageAnnotation s')
             )
         )
     )
@@ -216,3 +226,22 @@ execCompilationPipelineWithCmdline
             Nothing -> return (diags, Nothing)
       )
       flagsParser
+
+squeezeDiagnostics :: (Alter t) => t (Either [Diagnostic]) a -> Compile () (t Identity a)
+squeezeDiagnostics ast = do
+  _ <-
+    alter
+      ( \case
+          (Left l) -> tell l >> return (Left l)
+          r -> return r
+      )
+      return
+      ast
+
+  case squeeze ast of
+    (Left _) -> compilationFailure
+    (Right a) -> return a
+
+resolveOrFail :: Either [Diagnostic] a -> Compile s a
+resolveOrFail (Right a) = return a
+resolveOrFail (Left l) = tell l >> compilationFailure
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 3bdae4a..410f3e2 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -2,636 +2,283 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE IncoherentInstances #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Language.Fiddle.Compiler.ConsistencyCheck
-  ( checkConsistency,
-    consistencyCheckPhase,
-  )
-where
+module Language.Fiddle.Compiler.ConsistencyCheck (consistencyCheckPhase) where
 
-import Control.Monad (forM_, unless, when)
-import Control.Monad.RWS (MonadState (get, put), MonadWriter (tell), gets, modify')
-import Data.Foldable (foldlM)
+import Control.Monad (forM_, when)
+import Control.Monad.RWS (MonadWriter (tell))
+import Control.Monad.Trans.Writer (Writer, execWriter)
+import Data.Foldable (foldlM, toList)
 import Data.Functor.Identity
-import Data.List (intercalate)
-import Data.Maybe (mapMaybe)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Typeable
 import Data.Word (Word32)
 import GHC.TypeError as TypeError
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler
-import Language.Fiddle.Internal.Scopes
 import Language.Fiddle.Internal.UnitInterface as UnitInterface
-import Language.Fiddle.Types (Comment (DocComment), Commented (Commented, unCommented), SourceSpan)
-import Prelude hiding (unzip)
+import Language.Fiddle.Types
 import Text.Printf (printf)
+import Prelude hiding (unzip)
 
-import qualified Data.IntMap as IntMap
-import qualified Data.List.NonEmpty as NonEmpty
-import qualified Data.Text as Text
-
-data GlobalState = GlobalState
-  { globalScope :: Scope String (Either SizeBits SizeBytes),
-    _fileDependencies :: [FilePath],
-    unitInterface :: UnitInterface
-  }
-
-newtype LocalState = LocalState (ScopePath String)
-
-type CurrentStage = Qualified
-
-type I = Identity
-
-type Annot = Commented SourceSpan
+type S = Qualified
 
-type SizeBits = Word32
+type S' = Checked
 
-type SizeBytes = Word32
+type F = Identity
 
-consistencyCheckPhase :: CompilationPhase CurrentStage Checked
-consistencyCheckPhase = pureCompilationPhase checkConsistency
+type A = Commented SourceSpan
 
-checkConsistency ::
-  FiddleUnit CurrentStage I Annot ->
-  Compile () (FiddleUnit Checked I Annot)
-checkConsistency =
-  fmap snd
-    . subCompile (GlobalState mempty mempty mempty)
-    . advanceStage (LocalState mempty)
+type M = Compile ()
 
 instance CompilationStage Checked where
   type StageAfter Checked = TypeError (TypeError.Text "No stage after Checked")
-  type StageMonad Checked = Compile GlobalState
-  type StageState Checked = LocalState
+  type StageMonad Checked = M
+  type StageState Checked = ()
   type StageFunctor Checked = Identity
-  type StageAnnotation Checked = Commented SourceSpan
-
-instance CompilationStage CurrentStage where
-  type StageAfter CurrentStage = Checked
-  type StageMonad CurrentStage = Compile GlobalState
-  type StageState CurrentStage = LocalState
-  type StageFunctor CurrentStage = Identity
-  type StageAnnotation CurrentStage = Commented SourceSpan
-
-instance AdvanceStage CurrentStage FiddleUnit where
-  advanceStage localState (FiddleUnit _ decls a) = do
-    decls' <- mapM (advanceStage localState) decls
-    intf <- gets unitInterface
-    return $ FiddleUnit intf decls' a
+  type StageAnnotation Checked = A
 
--- advanceStage localState (FiddleUnit decls _ annot) = do
+instance CompilationStage S where
+  type StageAfter S = S'
+  type StageMonad S = M
+  type StageState S = ()
+  type StageFunctor S = F
+  type StageAnnotation S = A
 
---   decls' <- mapM (advanceStage localState) decls
+consistencyCheckPhase :: CompilationPhase S S'
+consistencyCheckPhase = pureCompilationPhase $ advanceStage ()
 
-deriving instance AdvanceStage CurrentStage Expression
+instance AdvanceStage S ObjTypeBody where
+  advanceStage () objTypeBody = snd <$> advanceObjTypeBody objTypeBody 0
 
-deriving instance AdvanceStage CurrentStage ObjType
+deriving instance AdvanceStage S DeferredRegisterBody
 
-deriving instance AdvanceStage CurrentStage DeferredRegisterBody
+deriving instance AdvanceStage S RegisterBody
 
-deriving instance AdvanceStage CurrentStage RegisterBitsDecl
+deriving instance AdvanceStage S AnonymousBitsType
 
-deriving instance AdvanceStage CurrentStage RegisterBitsTypeRef
+deriving instance AdvanceStage S ImportStatement
 
-deriving instance AdvanceStage CurrentStage AnonymousBitsType
+deriving instance AdvanceStage S BitType
 
-deriving instance AdvanceStage CurrentStage BitType
+deriving instance AdvanceStage S EnumBody
 
-deriving instance AdvanceStage CurrentStage EnumBody
+deriving instance AdvanceStage S EnumConstantDecl
 
-deriving instance AdvanceStage CurrentStage EnumConstantDecl
+deriving instance AdvanceStage S RegisterBitsDecl
 
-deriving instance AdvanceStage CurrentStage PackageBody
+deriving instance AdvanceStage S PackageBody
 
-instance AdvanceStage CurrentStage ImportStatement where
-  modifyState
-    ( ImportStatement
-        { importInterface =
-            ( UnitInterface
-                { rootScope = unitScope,
-                  dependencies = importDependencies
-                }
-              )
-        }
-      )
-    ls = do
-      modify'
-        ( \s@GlobalState
-             { globalScope = globalScope,
-               unitInterface = unitInterface
-             } ->
-              s
-                { globalScope =
-                    unitInterfaceScopeToGlobalScope unitScope <> globalScope,
-                  unitInterface =
-                    unitInterface
-                      { dependencies =
-                          importDependencies ++ dependencies unitInterface
-                      }
-                }
-        )
-      return ls
-      where
-        unitInterfaceScopeToGlobalScope =
-          fmap
-            ( \(_, exportedValue) -> case exportedValue of
-                ExportedBitsType sz -> Left sz
-                ExportedObjType sz -> Right sz
-            )
-
-deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t)
-
-instance AdvanceStage CurrentStage RegisterBody where
-  advanceStage s body = fst <$> registerBodyToStage3 s body
-
-instance AdvanceStage CurrentStage ObjTypeBody where
-  advanceStage s body = fst <$> objTypeBodyToStage3 s body 0
-
-deriving instance AdvanceStage CurrentStage FiddleDecl
-
-instance AdvanceStage CurrentStage (Directed FiddleDecl) where
-  modifyState (Directed _ t _) s = case t of
-    (BitsDecl _ id typ annotation) -> do
-      typeSize <- getTypeSize typ
-      insertTypeSize annotation s id typeSize
-      return s
-    (PackageDecl _ n _ _) -> do
-      let strs = nameToList n
-      let (LocalState scopePath) = s
-
-      return $
-        LocalState $
-          scopePath {currentScope = strs ++ currentScope scopePath}
-    (UsingDecl _ n _) ->
-      let (LocalState scopePath) = s
-       in return $
-            LocalState $
-              scopePath
-                { usingPaths = nameToList n : usingPaths scopePath
-                }
-    _ -> return s
-
-  customAdvanceStage (Directed directives t a) (LocalState scopePath) = case t of
-    (ObjTypeDecl q ident (Identity body) annot) -> do
-      (body', size) <- objTypeBodyToStage3 (LocalState scopePath) body 0
-
-      let fullName =
-            NonEmpty.prependList
-              (currentScope scopePath)
-              (NonEmpty.singleton (Text.unpack (identifierName ident)))
-
-      ui <- gets unitInterface
-      let ui' = insertIntoUnitInterface fullName ui annot (ExportedObjType size)
-      modify' $ \gs -> gs {unitInterface = ui'}
-
-      return $ Just $ Directed directives (ObjTypeDecl q ident (Identity body') annot) a
-    _ -> return Nothing
-
-objTypeBodyToStage3 ::
-  LocalState ->
-  ObjTypeBody CurrentStage I Annot ->
-  Word32 ->
-  Compile GlobalState (ObjTypeBody Checked I Annot, Word32)
-objTypeBodyToStage3 st (ObjTypeBody bodyType decls a) startOff = do
-  let isUnion = case bodyType of
-        Union {} -> True
-        _ -> False
-  (cur, returned) <-
-    foldlM
-      ( \(cursor, returned) decl ->
-          case undirected decl of
-            RegisterDecl mMod mIdent expr mBody a -> do
-              (s3RegisterBody, mCalculatedSize) <-
-                fUnzip <$> mapM (registerBodyToStage3 st) mBody
-
-              nExpr <- advanceStage st expr
-
-              let s3 =
-                    mapDirected
-                      ( const $
-                          RegisterDecl
-                            mMod
-                            mIdent
-                            nExpr
-                            s3RegisterBody
-                            a
-                      )
-                      decl
-
-              declaredSizeBits <- fromIntegral <$> exprToSize expr
-
-              when ((declaredSizeBits `mod` 8) /= 0) $
-                tell
-                  [ Diagnostic
-                      Error
-                      "Register size is not a multiple of 8. Please pad register size to align with 8. "
-                      (unCommented a)
-                  ]
-
-              forM_ mCalculatedSize $ \(fromIntegral -> calculatedSize) ->
-                unless (calculatedSize == declaredSizeBits) $
-                  let helpful =
-                        if calculatedSize < declaredSizeBits
-                          then
-                            printf
-                              "\nPerhaps you should add 'reserved(%d)' to the end of your register declaration?"
-                              (declaredSizeBits - calculatedSize)
-                          else ""
-                   in tell
-                        [ Diagnostic
-                            Error
-                            ( printf
-                                "Calculated size %d does not match declared size %d.%s"
-                                calculatedSize
-                                declaredSizeBits
-                                helpful
-                            )
-                            (unCommented a)
-                        ]
-
-              if isUnion
-                then
-                  checkUnion cursor (declaredSizeBits `div` 8) (s3 : returned) a
-                else
-                  return (cursor + declaredSizeBits `div` 8, s3 : returned)
-            TypeSubStructure (Identity subBody) maybeIdent annot -> do
-              (newBody, size) <-
-                objTypeBodyToStage3
-                  st
-                  subBody
-                  ( if isUnion then startOff else cursor
-                  )
-              let s3 = mapDirected (const $ TypeSubStructure (Identity newBody) maybeIdent annot) decl
-
-              checkTypesSubStructure subBody maybeIdent annot
-              if isUnion
-                then
-                  checkUnion cursor size (s3 : returned) a
-                else
-                  return (cursor + size, s3 : returned)
-            ReservedDecl expr annot -> do
-              size' <- fromIntegral <$> exprToSize expr
-              when ((size' `mod` 8) /= 0) $
-                tell
-                  [ Diagnostic
-                      Error
-                      "Can only reserve a multiple of 8 bits in this context."
-                      (unCommented a)
-                  ]
-
-              expr' <- advanceStage st expr
-              let size = size' `div` 8
-              let s3 = mapDirected (const $ ReservedDecl expr' annot) decl
-              if isUnion
-                then
-                  checkUnion cursor size (s3 : returned) a
-                else
-                  return (cursor + size, s3 : returned)
-            AssertPosStatement _ expr a -> do
-              declaredPos <- fromIntegral <$> exprToSize expr
-
-              let expectedPos = if isUnion then startOff else cursor + startOff
-
-              when (expectedPos /= declaredPos) $ do
-                tell
-                  [ Diagnostic
-                      Error
-                      ( printf
-                          "Position assertion failed. Asserted 0x%x, calculated 0x%x"
-                          declaredPos
-                          expectedPos
-                      )
-                      (unCommented a)
-                  ]
-              return (cursor, returned)
-      )
-      (0, [])
-      decls
+deriving instance AdvanceStage S FiddleDecl
 
-  return (ObjTypeBody bodyType (reverse returned) a, cur)
-  where
-    checkTypesSubStructure
-      (ObjTypeBody bodyType decls _)
-      maybeIdent
-      annot =
-        let emitWarning s = tell [Diagnostic Warning s (unCommented annot)]
-         in case () of
-              ()
-                | [_] <- decls,
-                  (Union {}) <- bodyType ->
-                    emitWarning "Union with a single field. Should this be a struct?"
-              ()
-                | [_] <- decls,
-                  (Struct {}) <- bodyType,
-                  Nothing <- maybeIdent ->
-                    emitWarning "Anonymous sub-struct with single field is superfluous."
-              ()
-                | [] <- decls ->
-                    emitWarning
-                      ( printf
-                          "Empty sub-%s is superfluous."
-                          ( case bodyType of
-                              Union {} -> "union"
-                              Struct {} -> "struct"
-                          )
-                      )
-              _ -> return ()
-    fUnzip xs = (fst <$> xs, snd <$> xs)
-
-registerBodyToStage3 ::
-  LocalState ->
-  RegisterBody CurrentStage I Annot ->
-  Compile GlobalState (RegisterBody Checked I Annot, Word32)
-registerBodyToStage3
-  st
-  (RegisterBody bodyType (Identity deferredRegisterBody) a') = do
-    let isUnion = case bodyType of
-          Union {} -> True
-          _ -> False
-
-    case deferredRegisterBody of
-      DeferredRegisterBody decls a -> do
-        (cur, returned) <-
-          foldlM
-            ( \(cursor, returned) decl ->
-                case undirected decl of
-                  ReservedBits expr a -> do
-                    size <- fromIntegral <$> exprToSize expr
-                    expr' <- advanceStage st expr
-                    let s3 =
-                          mapDirected
-                            (const $ ReservedBits expr' a)
-                            decl
-                    if isUnion
-                      then checkUnion cursor size (s3 : returned) a
-                      else
-                        return (cursor + size, s3 : returned)
-                  BitsSubStructure registerBody maybeIdent annot -> do
-                    checkBitsSubStructure registerBody maybeIdent annot
-
-                    (newBody, subsize) <- registerBodyToStage3 st registerBody
-                    let s3 =
-                          mapDirected
-                            (const $ BitsSubStructure newBody maybeIdent annot)
-                            decl
-
-                    if isUnion
-                      then checkUnion cursor subsize (s3 : returned) a
-                      else
-                        return (cursor + subsize, s3 : returned)
-                  DefinedBits modifier identifier typeref a -> do
-                    (s3TypeRef, size) <- registerBitsTypeRefToStage3 st typeref
-                    let s3 =
-                          mapDirected
-                            (const $ DefinedBits modifier identifier s3TypeRef a)
-                            decl
-
-                    if isUnion
-                      then checkUnion cursor size (s3 : returned) a
-                      else
-                        return (cursor + size, s3 : returned)
-            )
-            (0, [])
-            decls
-
-        return
-          ( RegisterBody
-              bodyType
-              (Identity (DeferredRegisterBody (reverse returned) a))
-              a',
-            cur
-          )
+instance AdvanceStage S FiddleUnit where
+  advanceStage () fu@(FiddleUnit _ decls a) =
+    FiddleUnit (getUnitInterface fu) <$> mapM (advanceStage ()) decls <*> pure a
     where
-      checkBitsSubStructure
-        (RegisterBody bodyType (Identity (DeferredRegisterBody decls _)) _)
-        maybeIdent
-        annot =
-          let emitWarning s = tell [Diagnostic Warning s (unCommented annot)]
-           in case () of
-                ()
-                  | [_] <- decls,
-                    (Union {}) <- bodyType ->
-                      emitWarning "Union with a single field. Should this be a struct?"
-                ()
-                  | [_] <- decls,
-                    (Struct {}) <- bodyType,
-                    Nothing <- maybeIdent ->
-                      emitWarning "Anonymous sub-struct with single field is superfluous."
-                ()
-                  | [] <- decls ->
-                      emitWarning
-                        ( printf
-                            "Empty sub-%s is superfluous."
-                            ( case bodyType of
-                                Union {} -> "union"
-                                Struct {} -> "struct"
-                            )
-                        )
-                _ -> return ()
-
-registerBitsTypeRefToStage3 ::
-  LocalState ->
-  RegisterBitsTypeRef CurrentStage I Annot ->
-  Compile GlobalState (RegisterBitsTypeRef Checked I Annot, Word32)
-registerBitsTypeRefToStage3 localState = \case
-  RegisterBitsArray ref expr a -> do
-    (ref', size) <- registerBitsTypeRefToStage3 localState ref
-    multiplier <- exprToSize expr
-    expr' <- advanceStage localState expr
-    return
-      ( RegisterBitsArray ref' expr' a,
-        size * fromIntegral multiplier
-      )
-  RegisterBitsReference q name a ->
-    (RegisterBitsReference q name a,) <$> lookupTypeSize localState name
-  RegisterBitsJustBits expr a -> do
-    expr' <- advanceStage localState expr
-    (RegisterBitsJustBits expr' a,)
-      . fromIntegral
-      <$> exprToSize expr
-
-checkUnion :: Word32 -> Word32 -> b -> Commented SourceSpan -> Compile s (Word32, b)
-checkUnion cursor subsize ret a = do
-  when (cursor /= 0 && subsize /= cursor) $ do
-    tell
-      [ Diagnostic
-          Warning
-          ( printf
-              "Jagged union found. Found size %d, expected %d.\n \
-              \ Please wrap smaller fields in a struct with padding so all \
-              \ fields are the same size?"
-              subsize
-              cursor
-          )
-          (unCommented a)
-      ]
-  return (max cursor subsize, ret)
-
-exprToSize ::
-  (NumberType stage ~ Integer) =>
-  Expression stage I Annot ->
-  Compile s Integer
-exprToSize (LitNum num _) = return num
-exprToSize e = do
-  tell [Diagnostic Error "Variables not allowed" (unCommented $ annot e)]
-  compilationFailure
-
-lookupTypeSize :: LocalState -> Name I Annot -> Compile GlobalState SizeBits
-lookupTypeSize (LocalState scopePath) (Name idents a) = do
-  -- Convert the list of identifiers to a string path
-  let path = fmap (\(Identifier s _) -> Text.unpack s) idents
-
-  -- Get the current scope and perform the lookup
-  results <- gets $ lookupScopeWithPath scopePath path . globalScope
-
-  case results of
-    -- Successfully resolved to a unique size
-    [(_, Left sz)] -> return sz
-    -- Multiple ambiguous results found
-    matches@(_ : _ : _) -> do
-      -- Generate a list of ambiguous paths for error reporting
-      let ambiguousPaths =
-            map
-              ( \(resolvedPath, _) ->
-                  intercalate "." (NonEmpty.toList resolvedPath)
-              )
-              matches
-      tell
-        [ Diagnostic
-            Error
-            ( printf
-                "Ambiguous occurrence of '%s'. Multiple matches found:\n%s"
-                (intercalate "." $ NonEmpty.toList path)