Add metadata information to the BitsSubStructure and compile it correctly.

5 files changed, 95 insertions, 17 deletions

diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 2774507..a4f98e3 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -119,7 +119,8 @@ regSzToBits RegSz64 = 64
 data QBitsMetadata (checkStage :: Bool) where
   QBitsMetadata ::
     { bitsSpan :: When checkStage (FieldSpan Bits),
-      bitsFullPath :: QualifiedPath String
+      bitsFullPath :: QualifiedPath String,
+      bitsUnnamed :: Bool
     } ->
     QBitsMetadata checkStage
   deriving (Generic, ToJSON)
@@ -666,7 +667,12 @@ data RegisterBitsDecl stage f a where
     RegisterBitsDecl stage f a
   -- | Substructure within a register.
   BitsSubStructure ::
-    { -- | The body of the substructure.
+    { -- | Metadata about the bits.
+      qBitsMetadata :: When (stage .>= Qualified) (QBitsMetadata (stage .>= Checked)),
+      -- | Modifier for these bits. Useful when multiple fields need to be set
+      -- atomically.
+      bitsModifier :: Guaranteed (stage .>= Qualified) (Modifier f a),
+      -- | The body of the substructure.
       bitsSubRegBody :: RegisterBody stage f a,
       -- | Optional name for the substructure.
       bitsSubName :: Maybe (Identifier f a),
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index 4b4b3ea..1ab22bb 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -361,6 +361,33 @@ pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef annot <-
       }
     )
 
+pattern BitsSubstructureP ::
+  Modifier f a ->
+  String ->
+  QualifiedPath String ->
+  N Bits ->
+  N Bits ->
+  RegisterBody Checked f A ->
+  A ->
+  RegisterBitsDecl Checked f A
+pattern BitsSubstructureP modifier bitsName bitsFullPath offset size subRegisterBody annot <-
+  BitsSubStructure
+    { qBitsMetadata =
+        Present
+          QBitsMetadata
+            { bitsSpan =
+                Present
+                  FieldSpan
+                    { offset = offset,
+                      size = size
+                    },
+              bitsFullPath = (basenamePart &&& id -> (bitsName, bitsFullPath))
+            },
+      bitsModifier = (Guaranteed modifier),
+      bitsSubRegBody = subRegisterBody,
+      bitsSubAnnot = annot
+    }
+
 writeBitsGet ::
   StructName ->
   QRegMetadata True ->
@@ -616,13 +643,13 @@ typeRefToArgs reg =
 -- decomposeBitsTypeRef (RegisterBitsJustBits )
 writeRegisterBody ::
   StructName -> QRegMetadata True -> RegisterBody Checked I A -> M SIntf
-writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk
+writeRegisterBody structName regmeta t = execWriterT $ walk (\t' () -> registerWalk t') t ()
   where
     registerWalk ::
       forall t.
       (Walk t, Typeable t) =>
       t I A ->
-      WriterT SIntf (FilesM () FormattedWriter CFileState) ()
+      WriterT SIntf (FilesM () FormattedWriter CFileState) (WalkContinuation ())
     registerWalk t = case () of
       ()
         | (Just (DefinedBitsP modifier _ fullPath offset typeRef annot)) <- castTS t ->
@@ -637,6 +664,31 @@ writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk
                       ( tell =<< lift (writeBitsGet structName regmeta fullPath offset typeRef annot),
                         tell =<< lift (writeBitsSet isWo structName regmeta fullPath offset typeRef annot)
                       )
+                  return Stop
+      () | (Just (BitsSubstructureP modifier bitsName fullPath offset size subBody annot)) <- castTS t -> do
+        sIntf <- lift (writeRegisterBody structName regmeta subBody)
+        let isWo = case modifier of
+              ModifierKeyword Wo _ -> True
+              _ -> False
+        if null bitsName
+          then tell sIntf
+          else do
+            -- Make a typeref here which is defined as "just bitse"
+            let typeRef =
+                  RegisterBitsJustBits
+                    (ConstExpression (LeftV size) annot)
+                    annot
+
+            tell $ sIntfSingleton bitsName sIntf
+            lift $ textM $ emitDocComments annot
+            sequence_ $
+              selectByModifier
+                modifier
+                ( tell =<< lift (writeBitsGet structName regmeta fullPath offset typeRef annot),
+                  tell =<< lift (writeBitsSet isWo structName regmeta fullPath offset typeRef annot)
+                )
+
+        return Stop
       -- text $
       --   Text.pack $
       --     printf
@@ -644,7 +696,7 @@ writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk
       --       bitsName
       --       (qualifiedPathToIdentifier fullPath)
       --       offset
-      _ -> return ()
+      _ -> return $ Continue ()
 
     castTS ::
       forall (t' :: SynTree) (t :: StagedSynTree) (f :: Type -> Type) (a :: Type).
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index f85d9d4..c4924da 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -299,9 +299,11 @@ advanceDecl offset = \case
 
     (size,)
       <$> (DefinedBits qmeta' mod ident <$> advanceStage () typ <*> pure annot)
-  BitsSubStructure subBody subName ann -> do
-    (sz, body') <- advanceRegisterBody offset subBody
-    return (sz, BitsSubStructure body' subName ann)
+  BitsSubStructure qmeta modifier subBody subName ann -> do
+    (size, body') <- advanceRegisterBody offset subBody
+    let span = Present (FieldSpan offset size)
+        qmeta' = fmap (\q -> q {bitsSpan = span}) qmeta
+    return (size, BitsSubStructure qmeta' modifier body' subName ann)
 
 bitsTypeSize :: RegisterBitsTypeRef S F A -> M (N Bits)
 bitsTypeSize (RegisterBitsArray tr nExpr _) = do
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index 8bae2de..ac99f48 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -159,9 +159,21 @@ deriving instance AdvanceStage S EnumConstantDecl
 instance AdvanceStage S RegisterBitsDecl where
   advanceStage localState = \case
     ReservedBits expr an -> ReservedBits <$> advanceStage localState expr <*> pure an
-    BitsSubStructure bod name an ->
-      BitsSubStructure
-        <$> advanceStage localState bod
+    BitsSubStructure Vacant mod bod name an -> do
+      let (path, localState') =
+            maybe
+              (fmap (const "") (currentQualifiedPath localState), localState)
+              ( \ident -> pushRegister (identToString ident) localState
+              )
+              name
+          qMeta =
+            QBitsMetadata
+              { bitsSpan = Vacant,
+                bitsFullPath = path,
+                bitsUnnamed = isNothing name
+              }
+      BitsSubStructure (Present qMeta) (guarantee (ModifierKeyword Rw an) mod)
+        <$> advanceStage localState' bod
         <*> pure name
         <*> pure an
     DefinedBits _ mod ident typ an -> do
@@ -169,7 +181,8 @@ instance AdvanceStage S RegisterBitsDecl where
           qMeta =
             QBitsMetadata
               { bitsSpan = Vacant,
-                bitsFullPath = path
+                bitsFullPath = path,
+                bitsUnnamed = False
               }
       DefinedBits (Present qMeta) (guarantee (ModifierKeyword Rw an) mod) ident
         <$> advanceStage localState typ
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index c3056bd..e91fa41 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -276,11 +276,16 @@ registerBitsDeclP =
     ( do
         tok KWReserved >> ReservedBits <$> exprInParenP
     )
-      <|> (BitsSubStructure <$> registerBodyP <*> optionMaybe ident)
-      <|> ( DefinedBits Vacant . Perhaps
-              <$> optionMaybe modifierP
-              <*> ident
-              <*> (tok TokColon >> registerBitsTypeRefP)
+      <|> ( do
+              mod <- optionMaybe modifierP
+              ( BitsSubStructure Vacant (Perhaps mod)
+                  <$> registerBodyP
+                  <*> optionMaybe ident
+                )
+                <|> ( DefinedBits Vacant (Perhaps mod)
+                        <$> ident
+                        <*> (tok TokColon >> registerBitsTypeRefP)
+                    )
           )
 
 registerBitsTypeRefP :: Pa RegisterBitsTypeRef