Change 'Expression' to use numbers with units.

This helps to catch bugs in the compiler, specifically ones related to
mixing up bits and bytes.

1 files changed, 50 insertions, 36 deletions

diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index e0c7876..4be2912 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -16,11 +16,11 @@ import qualified Data.IntMap as IntMap
 import Data.List (intercalate)
 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.UnitInterface as UnitInterface
+import Language.Fiddle.Internal.UnitNumbers
 import Language.Fiddle.Types
 import Text.Printf (printf)
 import Prelude hiding (unzip)
@@ -114,7 +114,7 @@ instance AdvanceStage S FiddleUnit where
         Maybe (t S f a)
       castTS = cast
 
-deriving instance AdvanceStage S Expression
+deriving instance AdvanceStage S (Expression u)
 
 deriving instance AdvanceStage S RegisterBitsTypeRef
 
@@ -122,7 +122,7 @@ deriving instance AdvanceStage S ObjType
 
 deriving instance (AdvanceStage S t) => AdvanceStage S (Directed t)
 
-advanceObjTypeBody :: ObjTypeBody S F A -> Word32 -> M (Word32, ObjTypeBody S' F A)
+advanceObjTypeBody :: ObjTypeBody S F A -> N Bytes -> M (N Bytes, ObjTypeBody S' F A)
 advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
   (decls', _) <- advanceDecls
 
@@ -134,13 +134,19 @@ advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
 
   return (calcSize, ObjTypeBody us (reverse $ map snd decls') a)
   where
-    advanceDecls :: M ([(Word32, Directed ObjTypeDecl S' F A)], Word32)
+    advanceDecls :: M ([(N Bytes, Directed ObjTypeDecl S' F A)], N Bytes)
     advanceDecls = do
       foldlM
         ( \(ret, offset) d ->
-            let advanceOffset = case us of
+            let advanceOffset :: N Bytes -> N Bytes -> N Bytes
+                advanceOffset = case us of
                   Union {} -> const
                   Struct {} -> (+)
+                doReturn ::
+                  (Monad m) =>
+                  ObjTypeDecl S' F A ->
+                  N Bytes ->
+                  m ([(N Bytes, Directed ObjTypeDecl S' F A)], N Bytes)
                 doReturn x size = return ((size, mapDirected (const x) d) : ret, advanceOffset offset size)
              in case undirected d of
                   e@AssertPosStatement {assertExpr = expr} -> do
@@ -149,28 +155,35 @@ advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
                     return (ret, offset)
                   (RegisterDecl _ mod ident size Nothing a) -> do
                     (sizeExpr, reifiedSize) <- advanceAndGetSize size
-                    let span = Present (FieldSpan (N offset) (N reifiedSize))
+                    reifiedSizeBytes <- checkBitsSizeMod8 a reifiedSize
+
+                    let span = Present (FieldSpan offset reifiedSizeBytes)
                     doReturn (RegisterDecl span mod ident sizeExpr Nothing a)
                       =<< checkBitsSizeMod8 a reifiedSize
                   (RegisterDecl _ mod ident size (Just body) a) -> do
                     declaredSize <- expressionToIntM size
                     (actualSize, body') <- advanceRegisterBody body
+
                     checkSizeMismatch a declaredSize actualSize
+
                     (sizeExpr, reifiedSize) <- advanceAndGetSize size
-                    let span = Present (FieldSpan (N offset) (N reifiedSize))
-                    doReturn (RegisterDecl span mod ident sizeExpr (Just body') a)
-                      =<< checkBitsSizeMod8 a reifiedSize
+                    reifiedSizeBytes <- checkBitsSizeMod8 a reifiedSize
+
+                    let span = Present (FieldSpan offset reifiedSizeBytes)
+                    doReturn (RegisterDecl span mod ident sizeExpr (Just body') a) reifiedSizeBytes
                   (ReservedDecl _ i size a) -> do
                     (sizeExpr, reifiedSize) <- advanceAndGetSize size
-                    let span = Present (FieldSpan (N offset) (N reifiedSize))
-                    doReturn (ReservedDecl span i sizeExpr a) reifiedSize
+                    reifiedSizeBytes <- checkBitsSizeMod8 a reifiedSize
+                    let span = Present (FieldSpan offset reifiedSizeBytes)
+                    doReturn (ReservedDecl span i sizeExpr a) reifiedSizeBytes
                   (TypeSubStructure (Identity body) name a) -> do
                     (size, body') <- advanceObjTypeBody body offset
                     doReturn (TypeSubStructure (Identity body') name a) size
         )
-        (([], startOffset) :: ([(Word32, Directed ObjTypeDecl S' F A)], Word32))
+        (([], startOffset) :: ([(N Bytes, Directed ObjTypeDecl S' F A)], N Bytes))
         decls
 
+    advanceAndGetSize :: Expression u S F A -> M (Expression u S' F A, N u)
     advanceAndGetSize e = (,) <$> advanceStage () e <*> expressionToIntM e
 
 pattern RegisterBodyPattern :: BodyType F A -> [Directed RegisterBitsDecl s F A] -> A -> A -> RegisterBody s F A
@@ -178,7 +191,7 @@ pattern RegisterBodyPattern u decls a b = RegisterBody u (Identity (DeferredRegi
 
 -- registerBodyPattern u decls a b = RegisterBody u (Identity (DeferredRegisterBody decls a)) a
 
-advanceRegisterBody :: RegisterBody S F A -> M (Word32, RegisterBody S' F A)
+advanceRegisterBody :: RegisterBody S F A -> M (N Bits, RegisterBody S' F A)
 -- Handle the case where it's a union.
 advanceRegisterBody
   (RegisterBodyPattern us (NonEmpty.nonEmpty -> Just decls) a b) = do
@@ -207,7 +220,7 @@ advanceRegisterBody (RegisterBodyPattern u _ a b) =
   return (0, RegisterBodyPattern u [] a b)
 advanceRegisterBody RegisterBody {} = error "GHC not smart enuf"
 
-checkJagged :: (Annotated t) => [(Word32, t f A)] -> Compile s ()
+checkJagged :: (Annotated t) => [(N u, t f A)] -> Compile s ()
 checkJagged decls = do
   let expectedSize = maximum (fmap fst decls)
   forM_ decls $ \(sz, annot -> a) ->
@@ -223,7 +236,7 @@ checkJagged decls = do
         )
         a
 
-advanceDecl :: Word32 -> RegisterBitsDecl S F A -> M (Word32, RegisterBitsDecl S' F A)
+advanceDecl :: N Bits -> RegisterBitsDecl S F A -> M (N Bits, RegisterBitsDecl S' F A)
 advanceDecl offset = \case
   ReservedBits expr an -> do
     sz <- expressionToIntM expr
@@ -234,18 +247,18 @@ advanceDecl offset = \case
           )
   DefinedBits _ mod ident typ annot -> do
     size <- bitsTypeSize typ
-    let span = Present (FieldSpan (N offset) (N size))
+    let span = Present (FieldSpan offset size)
     (size,)
       <$> (DefinedBits span mod ident <$> advanceStage () typ <*> pure annot)
   BitsSubStructure subBody subName ann -> do
     (sz, body') <- advanceRegisterBody subBody
     return (sz, BitsSubStructure body' subName ann)
 
-bitsTypeSize :: RegisterBitsTypeRef S F A -> M Word32
+bitsTypeSize :: RegisterBitsTypeRef S F A -> M (N Bits)
 bitsTypeSize (RegisterBitsArray tr nExpr _) = do
   sz <- bitsTypeSize tr
   n <- expressionToIntM nExpr
-  return (sz * n)
+  return (sz .*. n)
 bitsTypeSize
   RegisterBitsReference
     { bitsRefQualificationMetadata =
@@ -255,18 +268,18 @@ bitsTypeSize (RegisterBitsReference {}) = error "should be exhaustive"
 bitsTypeSize (RegisterBitsJustBits expr _) =
   expressionToIntM expr
 
-checkSizeMismatch :: A -> Word32 -> Word32 -> Compile s ()
+checkSizeMismatch :: (NamedUnit u) => A -> N u -> N u -> Compile s ()
 checkSizeMismatch _ a b | a == b = return ()
 checkSizeMismatch pos declaredSize calculatedSize =
   emitDiagnosticError
     ( printf
-        "Size assertion failed. Declared size %d, calculated %d"
-        declaredSize
-        calculatedSize
+        "Size assertion failed. Declared size %s, calculated %s"
+        (unitName declaredSize)
+        (unitName calculatedSize)
     )
     pos
 
-checkPositionAssertion :: A -> Word32 -> Word32 -> Compile s ()
+checkPositionAssertion :: A -> N u -> N u -> Compile s ()
 checkPositionAssertion _ a b | a == b = return ()
 checkPositionAssertion pos declaredPosition calculatedPostion =
   emitDiagnosticError
@@ -278,9 +291,9 @@ checkPositionAssertion pos declaredPosition calculatedPostion =
     pos
 
 expressionToIntM ::
-  (Integral i, Integral (NumberType stage)) =>
-  Expression stage f A ->
-  Compile s i
+  (stage .< Expanded ~ False) =>
+  Expression u stage f A ->
+  Compile s (N u)
 expressionToIntM expr =
   resolveOrFail $
     either
@@ -289,21 +302,22 @@ expressionToIntM expr =
       return
       (expressionToInt expr)
 
-checkBitsSizeMod8 :: A -> Word32 -> M Word32
-checkBitsSizeMod8 _ w | w `mod` 8 == 0 = return (w `div` 8)
+checkBitsSizeMod8 :: A -> N Bits -> M (N Bytes)
 checkBitsSizeMod8 a w = do
-  emitDiagnosticWarning
-    (printf "Register size %d is not a multiple of 8. Please add padding to this register." w)
-    a
-  return ((w `div` 8) + 1)
-
-checkEnumConsistency :: Expression S F A -> EnumBody S F A -> M ()
+  let (x, rem) = bitsToBytes w
+  when (rem /= 0) $
+    emitDiagnosticError
+      (printf "Register size %d is not a multiple of 8. Please add padding to this register." w)
+      a
+  return x
+
+checkEnumConsistency :: Expression Bits S F A -> EnumBody S F A -> M ()
 checkEnumConsistency expr enumBody@(EnumBody {enumConsts = constants}) = do
   declaredSize <- expressionToIntM expr
 
   -- If the declared size is less than or equal to 4, we'll enforce that the
   -- enum is packed. This is to make sure the user has covered all bases.
-  when (declaredSize <= (4 :: Word32)) $ do
+  when (declaredSize <= 4) $ do
     imap <-
       foldlM
         ( \imap (undirected -> enumConst) -> do
@@ -311,7 +325,7 @@ checkEnumConsistency expr enumBody@(EnumBody {enumConsts = constants}) = do
               EnumConstantDecl _ expr _ -> expressionToIntM expr
               EnumConstantReserved expr _ -> expressionToIntM expr
 
-            when (number >= (2 :: Word32) ^ declaredSize) $
+            when (number >= 2 ^ declaredSize) $
               emitDiagnosticError
                 ( printf
                     "Enum constant too large. Max allowed %d\n"