Some major changes to the structure of the language.

Added structures and unions to better define the layout and model
overlapping concerns.

renamed objtype -> type and object -> instance.

added reserved statements for types.

2 files changed, 182 insertions, 38 deletions

diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs
index 3a97757..25ee66b 100644
--- a/src/Language/Fiddle/Compiler/Stage1.hs
+++ b/src/Language/Fiddle/Compiler/Stage1.hs
@@ -123,11 +123,20 @@ enumConstantToStage2 path = \case
   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
+objTypeBodyToStage2 path (ObjTypeBody bodyType decls annot) =
+  ObjTypeBody bodyType <$> 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
+  (TypeSubStructure (Identity deferredBody) maybeIdent annot) ->
+    let path' = maybe path (`pushId` path) maybeIdent
+     in TypeSubStructure . Identity
+          <$> objTypeBodyToStage2 path' deferredBody
+          <*> pure maybeIdent
+          <*> pure annot
+  (ReservedDecl expr a) ->
+    ReservedDecl <$> toStage2Expr expr <*> pure a
   (RegisterDecl maybeModifier maybeIdentifier expression maybeBody annot) ->
     let path' = maybe path (`pushId` path) maybeIdentifier
      in RegisterDecl
@@ -138,8 +147,8 @@ objTypeDeclToStage2 path = \case
           <*> pure annot
 
 registerBodyToStage2 :: Path -> RegisterBody Stage1 I Annot -> M Annot (RegisterBody Stage2 I Annot)
-registerBodyToStage2 path (RegisterBody (Identity (DeferredRegisterBody registerBitsDecl a1)) a2) =
-  RegisterBody . Identity
+registerBodyToStage2 path (RegisterBody bodyType (Identity (DeferredRegisterBody registerBitsDecl a1)) a2) =
+  RegisterBody bodyType . Identity
     <$> ( DeferredRegisterBody
             <$> mapM (registerBitsDeclToStage2 path) registerBitsDecl
             <*> pure a1
@@ -149,6 +158,9 @@ registerBodyToStage2 path (RegisterBody (Identity (DeferredRegisterBody register
 registerBitsDeclToStage2 :: Path -> RegisterBitsDecl Stage1 I Annot -> M Annot (RegisterBitsDecl Stage2 I Annot)
 registerBitsDeclToStage2 path = \case
   ReservedBits expr a -> ReservedBits <$> toStage2Expr expr <*> pure a
+  BitsSubStructure registerBody maybeIdent annot ->
+    let path' = maybe path (`pushId` path) maybeIdent
+     in BitsSubStructure <$> registerBodyToStage2 path' registerBody <*> pure maybeIdent <*> pure annot
   DefinedBits maybeModifier identifier registerBitsTyperef annot ->
     let path' = pushId identifier path
      in ( DefinedBits
diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/Stage2.hs
index baa61e3..727f153 100644
--- a/src/Language/Fiddle/Compiler/Stage2.hs
+++ b/src/Language/Fiddle/Compiler/Stage2.hs
@@ -117,8 +117,8 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do
         [ Diagnostic
             Warning
             ( printf
-                "Missing enum constants %s. Please fully pack a small enum.\
-                \ Use 'reserved' if needed."
+                "Missing enum constants %s. Small enums should be fully \
+                \ populated. Use 'reserved' if needed."
                 (intercalate ", " (map show missing))
             )
             (unCommented ann)
@@ -136,7 +136,7 @@ fiddleDeclToStage3 = \case
     addTypeSize id typeSize
     BitsDecl id <$> bitTypeToStage3 typ <*> pure a
   ObjTypeDecl ident body a ->
-    ObjTypeDecl ident <$> mapM objTypeBodyToStage3 body <*> pure a
+    ObjTypeDecl ident <$> mapM (\bt -> fst <$> objTypeBodyToStage3 bt 0) body <*> pure a
   ObjectDecl ident expr typ a ->
     ObjectDecl ident (expressionToStage3 expr) <$> objTypeToStage3 typ <*> pure a
 
@@ -152,7 +152,11 @@ objTypeToStage3 = \case
 registerBodyToStage3 ::
   RegisterBody Stage2 I Annot ->
   Compile Stage3State (RegisterBody Stage3 I Annot, Word32)
-registerBodyToStage3 (RegisterBody (Identity deferredRegisterBody) a') =
+registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a') = do
+  let isUnion = case bodyType of
+        Union {} -> True
+        _ -> False
+
   case deferredRegisterBody of
     DeferredRegisterBody decls a -> do
       (cur, returned) <-
@@ -160,17 +164,79 @@ registerBodyToStage3 (RegisterBody (Identity deferredRegisterBody) a') =
           ( \(cursor, returned) decl ->
               case decl of
                 ReservedBits expr a -> do
-                  size <- exprToSize expr
+                  size <- fromIntegral <$> exprToSize expr
                   let s3 = ReservedBits (expressionToStage3 expr) a
-                  return (cursor + fromIntegral size, s3 : returned)
+                  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 registerBody
+                  let s3 = BitsSubStructure newBody maybeIdent annot
+
+                  if isUnion
+                    then checkUnion cursor subsize (s3 : returned) a
+                    else
+                      return (cursor + subsize, s3 : returned)
                 DefinedBits modifier identifier typeref a -> do
                   (s3TypeRef, size) <- registerBitsTypeRefToStage3 typeref
-                  return (cursor + size, DefinedBits modifier identifier s3TypeRef a : returned)
+                  let s3 = DefinedBits modifier identifier s3TypeRef a
+
+                  if isUnion
+                    then checkUnion cursor size (s3 : returned) a
+                    else
+                      return (cursor + size, s3 : returned)
           )
           (0, [])
           decls
 
-      return (RegisterBody (Identity (DeferredRegisterBody (reverse returned) a)) a', cur)
+      return (RegisterBody bodyType (Identity (DeferredRegisterBody (reverse returned) a)) a', cur)
+  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 ()
+
+checkUnion :: Word32 -> Word32 -> b -> Commented SourceSpan -> Compile Stage3State (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)
 
 registerBitsTypeRefToStage3 ::
   RegisterBitsTypeRef Stage2 I Annot ->
@@ -191,8 +257,11 @@ registerBitsTypeRefToStage3 = \case
       <$> exprToSize expr
 
 objTypeBodyToStage3 ::
-  ObjTypeBody Stage2 I Annot -> Compile Stage3State (ObjTypeBody Stage3 I Annot)
-objTypeBodyToStage3 (ObjTypeBody decls a) = do
+  ObjTypeBody Stage2 I Annot -> Word32 -> Compile Stage3State (ObjTypeBody Stage3 I Annot, Word32)
+objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do
+  let isUnion = case bodyType of
+        Union {} -> True
+        _ -> False
   (cur, returned) <-
     foldlM
       ( \(cursor, returned) decl ->
@@ -209,7 +278,7 @@ objTypeBodyToStage3 (ObjTypeBody decls a) = do
                       s3RegisterBody
                       a
 
-              declaredSizeBits <- exprToSize expr
+              declaredSizeBits <- fromIntegral <$> exprToSize expr
 
               when ((declaredSizeBits `mod` 8) /= 0) $
                 tell
@@ -222,45 +291,108 @@ objTypeBodyToStage3 (ObjTypeBody decls a) = do
               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)
-                    ]
-
-              return (cursor + declaredSizeBits `div` 8, s3 : returned)
+                        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
+                  subBody
+                  ( if isUnion then startOff else cursor
+                  )
+              let s3 = TypeSubStructure (Identity newBody) maybeIdent annot
+
+              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)
+                  ]
+              let size = size' `div` 8
+              let s3 = ReservedDecl (expressionToStage3 expr) annot
+              if isUnion
+                then
+                  checkUnion cursor size (s3 : returned) a
+                else
+                  return (cursor + size, s3 : returned)
             AssertPosStatement expr a -> do
-              declaredPos <- exprToSize expr
-              when (cursor /= declaredPos) $ 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
-                          cursor
+                          expectedPos
                       )
                       (unCommented a)
                   ]
               return (cursor, returned)
       )
-      (0 :: Integer, [])
+      (0, [])
       decls
 
-  return $ ObjTypeBody (reverse returned) a
+  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)
     pushApply :: Maybe (a, b) -> (Maybe a, Maybe b)
     pushApply (Just (a, b)) = (Just a, Just b)