Provide more data during qualification about how a path is qualified.

Now it includes information about the package a symobl is in. The object
its in and the register its in. This allows better code generation in
the backend that's somewhat more organized.

4 files changed, 211 insertions, 84 deletions

diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index df31c8c..f4132c6 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -26,6 +26,7 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler.Backend
+import Language.Fiddle.Compiler.Backend.Internal
 import Language.Fiddle.Compiler.Backend.Internal.FormattedWriter
 import qualified Language.Fiddle.Compiler.Backend.Internal.FragTree as FragTree
 import Language.Fiddle.Compiler.Backend.Internal.Writer
@@ -174,8 +175,8 @@ instance IsText String where
 instance IsText Text where
   toText = id
 
-qualifiedPathToIdentifier :: (Foldable f, IsText t) => f t -> Text
-qualifiedPathToIdentifier = Text.intercalate "_" . map toText . toList
+qualifiedPathToIdentifier :: QualifiedPath String -> Text
+qualifiedPathToIdentifier = Text.pack . qualifiedPathToString "__" "_"
 
 pad :: M () -> M ()
 pad f = text "\n" *> f <* text "\n"
@@ -219,9 +220,9 @@ writeRegGet
         regFullPath = fullPath
       }
     ) = do
-    let fnName = "get_" <> qualifiedPathToIdentifier fullPath
+    let fnName = qualifiedPathToIdentifier fullPath <> "__get"
         returnType = sizeToType size
-        fieldName = NonEmpty.last fullPath
+        fieldName = basenamePart fullPath
 
     case returnType of
       Just rt -> do
@@ -257,16 +258,16 @@ writeRegSet
         regFullPath = fullPath
       }
     ) = do
-    let fnName = "set_" <> qualifiedPathToIdentifier fullPath
+    let fnName = qualifiedPathToIdentifier fullPath <> "__set"
         setType = sizeToType size
-        fieldName = NonEmpty.last fullPath
+        fieldName = basenamePart fullPath
 
     case setType of
       Just rt -> do
         textM $ do
           tell $
             Text.pack $
-              printf "static inline void %s(%s* o, %s v) {\n" fnName structType rt
+              printf "static inline void %s(struct %s* o, %s v) {\n" fnName structType rt
           tell $ Text.pack $ printf "  o->%s = v;\n" fieldName
           tell "}\n\n"
       Nothing ->
@@ -275,7 +276,7 @@ writeRegSet
           tell $
             Text.pack $
               printf
-                "static inline void %s(%s* o, const uint8_t in[%d]) {\n"
+                "static inline void %s(struct %s* o, const uint8_t in[%d]) {\n"
                 fnName
                 structType
                 size
@@ -283,8 +284,8 @@ writeRegSet
             tell $ Text.pack $ printf "  o->%s[%d] = in[%d];\n" fieldName i i
           tell "}\n\n"
 
-pattern DefinedBitsP :: String -> NonEmpty String -> N Bits -> RegisterBitsTypeRef Checked f a -> RegisterBitsDecl Checked f a
-pattern DefinedBitsP bitsName bitsFullPath offset typeRef <-
+pattern DefinedBitsP :: Modifier f a -> String -> QualifiedPath String -> N Bits -> RegisterBitsTypeRef Checked f a -> RegisterBitsDecl Checked f a
+pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef <-
   ( DefinedBits
       { qBitsMetadata =
           Present
@@ -294,12 +295,68 @@ pattern DefinedBitsP bitsName bitsFullPath offset typeRef <-
                     FieldSpan
                       { offset = offset
                       },
-                bitsFullPath = (NonEmpty.last &&& id -> (bitsName, bitsFullPath))
+                bitsFullPath = (basenamePart &&& id -> (bitsName, bitsFullPath))
               },
-        definedBitsTypeRef = typeRef
+        definedBitsTypeRef = typeRef,
+        definedBitsModifier = (Guaranteed modifier)
       }
     )
 
+writeBitsGet ::
+  StructName ->
+  String ->
+  QualifiedPath String ->
+  N Bits ->
+  RegisterBitsTypeRef 'Checked I A ->
+  M ()
+writeBitsGet _ _ _ _ _ = return ()
+
+writeBitsSet ::
+  StructName ->
+  String ->
+  QualifiedPath String ->
+  N Bits ->
+  RegisterBitsTypeRef 'Checked I A ->
+  M ()
+writeBitsSet structName bitsNam fullPath offset typeRef = do
+  text "inline static void "
+  text (qualifiedPathToIdentifier fullPath)
+  text "__set(\n    struct "
+  text structName
+  text " *o,\n    "
+  typeRefToArgs typeRef
+  text ") {\n"
+  text "}\n\n"
+
+typeRefToArgs :: RegisterBitsTypeRef 'Checked I A -> M ()
+typeRefToArgs reg =
+  text
+    $ Text.intercalate ",\n    "
+    $ zipWith
+      (\n t -> t <> " " <> n)
+      setterArgumentNames
+    $ typeRefToArgs' reg
+  where
+    typeRefToArgs'
+      ( RegisterBitsJustBits
+          { justBitsExpr = ConstExpression (LeftV v) _
+          }
+        ) = [typeForBits v]
+    typeRefToArgs'
+      ( RegisterBitsReference
+          { bitsRefQualificationMetadata = (Identity (Present md))
+          }
+        ) = [qualifiedPathToIdentifier $ metadataFullyQualifiedPath $ getMetadata md]
+    typeRefToArgs' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) =
+      typeRefToArgs' tr ++ ["int"]
+
+    typeForBits = \case
+      64 -> "uint64_t"
+      32 -> "uint32_t"
+      16 -> "uint16_t"
+      8 -> "uint8_t"
+      _ -> "unsigend"
+
 -- | Decomposes a type ref into a type name (String) and a list of dimensions
 -- (in the case of being an array)
 -- decomposeBitsTypeRef :: RegisterBitsTypeRef Checked I A -> (String, [N Unitless])
@@ -310,14 +367,21 @@ writeRegisterBody structName regmeta = walk_ registerWalk
     registerWalk :: forall t. (Walk t, Typeable t) => t I A -> M ()
     registerWalk t = case () of
       ()
-        | (Just (DefinedBitsP bitsName fullPath offset typeRef)) <- castTS t ->
-            text $
-              Text.pack $
-                printf
-                  "// Emit bits %s (%s) at %d\n"
-                  bitsName
-                  (qualifiedPathToIdentifier fullPath)
-                  offset
+        | (Just (DefinedBitsP modifier bitsName fullPath offset typeRef)) <- castTS t -> do
+            sequence_ $
+              selectByModifier
+                modifier
+                ( writeBitsGet structName bitsName fullPath offset typeRef,
+                  writeBitsSet structName bitsName fullPath offset typeRef
+                )
+
+      -- text $
+      --   Text.pack $
+      --     printf
+      --       "// Emit bits %s (%s) at %d\n"
+      --       bitsName
+      --       (qualifiedPathToIdentifier fullPath)
+      --       offset
       _ -> return ()
 
     castTS ::
diff --git a/src/Language/Fiddle/Compiler/Backend/Internal.hs b/src/Language/Fiddle/Compiler/Backend/Internal.hs
new file mode 100644
index 0000000..4e513f1
--- /dev/null
+++ b/src/Language/Fiddle/Compiler/Backend/Internal.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.Fiddle.Compiler.Backend.Internal where
+
+import qualified Data.Text
+
+-- | An infinite list of common setter argument names to use.
+setterArgumentNames :: [Data.Text.Text]
+setterArgumentNames =
+  ["value", "i", "j", "k"]
+    ++ map (("i" <>) . Data.Text.pack . show) [(0 :: Int) ..]
+
+-- | An infinite list of common getter argument names to use. A getter will have
+-- an argument for each index into an array for bit arrays.
+getterArgumentNames :: [Data.Text.Text]
+getterArgumentNames =
+  ["i", "j", "k"]
+    ++ map (("i" <>) . Data.Text.pack . show) [(0 :: Int) ..]
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 6a3b5d9..a8d9758 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -266,8 +266,7 @@ bitsTypeSize
         QMdP (ExportedBitsDecl {exportedBitsDeclSizeBits = sz})
     } = return sz
 bitsTypeSize (RegisterBitsReference {}) = error "should be exhaustive"
-bitsTypeSize (RegisterBitsJustBits expr _) =
-  expressionToIntM expr
+bitsTypeSize (RegisterBitsJustBits expr _) = return $ trueValue expr
 
 checkSizeMismatch :: (NamedUnit u) => A -> N u -> N u -> Compile s ()
 checkSizeMismatch _ a b | a == b = return ()
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index 56f1122..1307c2a 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -37,6 +37,8 @@ data GlobalState = GlobalState
 
 data LocalState = LocalState
   { currentScopePath :: ScopePath String,
+    -- | Current qualified path, used for building metadata.
+    currentQualifiedPath :: QualifiedPath (),
     ephemeralScope :: Scope String (Metadata, ExportedDecl)
   }
 
@@ -62,29 +64,62 @@ instance CompilationStage Expanded where
   type StageFunctor Expanded = F
   type StageAnnotation Expanded = A
 
+pushPackage :: NonEmpty String -> LocalState -> (QualifiedPath String, LocalState)
+pushPackage pk ls =
+  let q = currentQualifiedPath ls
+   in ( qualifyPackage pk,
+        ls
+          { currentScopePath = pushScope pk (currentScopePath ls),
+            currentQualifiedPath =
+              q
+                { packagePart = packagePart q ++ NonEmpty.toList pk
+                }
+          }
+      )
+  where
+    qualifyPackage :: NonEmpty String -> QualifiedPath String
+    qualifyPackage (NonEmpty.reverse -> (l :| (reverse -> h))) =
+      let q = currentQualifiedPath ls
+       in q {packagePart = packagePart q ++ h, basenamePart = l}
+
+pushObject :: String -> LocalState -> (QualifiedPath String, LocalState)
+pushObject objName ls =
+  let q = currentQualifiedPath ls
+   in ( fmap (const objName) q,
+        ls
+          { currentScopePath = pushScope (NonEmpty.singleton objName) (currentScopePath ls),
+            currentQualifiedPath =
+              q
+                { objectPart = Just objName
+                }
+          }
+      )
+
+pushRegister :: String -> LocalState -> (QualifiedPath String, LocalState)
+pushRegister regName ls =
+  let q = currentQualifiedPath ls
+   in ( fmap (const regName) q,
+        ls
+          { currentScopePath = pushScope (NonEmpty.singleton regName) (currentScopePath ls),
+            currentQualifiedPath =
+              q
+                { registerPart = registerPart q  ++ [regName]
+                }
+          }
+      )
+
 qualificationPhase :: CompilationPhase Expanded Qualified
 qualificationPhase =
-  pureCompilationPhase $ \t -> do
-    raw <-
-      fmap snd $
-        subCompile (GlobalState mempty 0) $
-          advanceStage
-            (LocalState mempty mempty)
-            (soakA t)
-
-    squeezeDiagnostics raw
-
-pushIdent :: Identifier f a -> LocalState -> LocalState
-pushIdent i = pushIdents [i]
-
-pushIdents :: (Foldable t) => t (Identifier f a) -> LocalState -> LocalState
-pushIdents =
-  ( \case
-      [] -> id
-      (i : is) ->
-        modifyCurrentScopePath (pushScope $ fmap identToString (i :| is))
-  )
-    . toList
+  let initialQualifiedPath = QualifiedPath [] Nothing [] ()
+   in pureCompilationPhase $ \t -> do
+        raw <-
+          fmap snd $
+            subCompile (GlobalState mempty 0) $
+              advanceStage
+                (LocalState mempty initialQualifiedPath mempty)
+                (soakA t)
+
+        squeezeDiagnostics raw
 
 instance
   StageConvertible
@@ -98,7 +133,7 @@ instance AdvanceStage S (ConstExpression u) where
   advanceStage ls (ConstExpression (RightV exp) a) =
     case exp of
       Var var _ -> do
-        (_, ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls
+        (ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls
         return $ ConstExpression (LeftV $ fromIntegral v) a
       LitNum (RightV v) _ -> return $ ConstExpression (LeftV v) a
 
@@ -127,15 +162,13 @@ instance AdvanceStage S RegisterBitsDecl where
         <*> pure name
         <*> pure an
     DefinedBits _ mod ident typ an -> do
-      let qMeta =
+      let (path, _) = pushObject (identToString ident) localState
+          qMeta =
             QBitsMetadata
               { bitsSpan = Vacant,
-                bitsFullPath =
-                  qualifyPath
-                    (currentScopePath localState)
-                    (NonEmpty.singleton (identToString ident))
+                bitsFullPath = path
               }
-      DefinedBits (Present qMeta) mod ident
+      DefinedBits (Present qMeta) (guarantee (ModifierKeyword Rw an) mod) ident
         <$> advanceStage localState typ
         <*> pure an
 
@@ -145,38 +178,39 @@ instance AdvanceStage S ObjTypeDecl where
       AssertPosStatement d <$> advanceStage localState e <*> pure a
     RegisterDecl _ mod ident size bod ann -> do
       ident' <- guaranteeM (uniqueIdentifier "reg" ann) ident
-      let localState' = pushIdents ident localState
+
+      let (qualified, localState') =
+            pushRegister (identToString $ unwrap ident') localState
+          -- Avoid pushing the anonymized name onto the stack.
+          localState'' =
+            if isNothing (toMaybe ident) then localState else localState'
 
       let qRegMeta =
             QRegMetadata
               { regSpan = Vacant,
                 regIsPadding = False,
                 regIsUnnamed = isNothing (toMaybe ident),
-                regFullPath =
-                  qualifyPath
-                    (currentScopePath localState)
-                    (NonEmpty.singleton (identToString (unwrap ident')))
+                regFullPath = qualified
               }
 
       RegisterDecl
         (Present qRegMeta)
         (guarantee (ModifierKeyword Rw ann) mod)
         ident'
-        <$> advanceStage localState' size
-        <*> mapM (advanceStage localState') bod
+        <$> advanceStage localState'' size
+        <*> mapM (advanceStage localState'') bod
         <*> pure ann
     ReservedDecl _ expr ann -> do
       ident <- uniqueIdentifier "reserved" ann
 
+      let (q, _) = pushRegister (identToString ident) localState
+
       let qRegMeta =
             QRegMetadata
               { regSpan = Vacant,
                 regIsPadding = True,
                 regIsUnnamed = True,
-                regFullPath =
-                  qualifyPath
-                    (currentScopePath localState)
-                    (NonEmpty.singleton (identToString ident))
+                regFullPath = q
               }
 
       RegisterDecl
@@ -187,7 +221,11 @@ instance AdvanceStage S ObjTypeDecl where
         <*> pure Nothing
         <*> pure ann
     TypeSubStructure bod name an -> do
-      let localState' = pushIdents name localState
+      let localState' =
+            maybe
+              localState
+              (\n -> snd $ pushRegister (identToString n) localState)
+              name
       TypeSubStructure
         <$> mapM (advanceStage localState') bod
         <*> pure name
@@ -207,7 +245,7 @@ instance AdvanceStage S RegisterBitsTypeRef where
         <$> advanceStage localState a
         <*> pure b
     RegisterBitsReference _ name a -> do
-      v <- fmap (Present . snd) <$> resolveName name localState
+      v <- fmap Present <$> resolveName name localState
       return $ RegisterBitsReference v name a
 
 instance AdvanceStage S ObjType where
@@ -218,7 +256,7 @@ instance AdvanceStage S ObjType where
         <*> advanceStage localState b
         <*> pure c
     ReferencedObjType _ name a -> do
-      v <- fmap (Present . snd) <$> resolveName name localState
+      v <- fmap Present <$> resolveName name localState
       return $ ReferencedObjType v name a
 
 deriving instance (AdvanceStage S t) => AdvanceStage S (Directed t)
@@ -246,13 +284,13 @@ modifyCurrentScopePath ::
 modifyCurrentScopePath fn ls@LocalState {currentScopePath = cs} =
   ls {currentScopePath = fn cs}
 
-resolveIdent :: (ExportableDecl d, Functor f) => Identifier f A -> LocalState -> M (F ([String], d))
+resolveIdent :: (ExportableDecl d, Functor f) => Identifier f A -> LocalState -> M (F d)
 resolveIdent i = resolveSymbol (annot i) [identToString i]
 
-resolveName :: (ExportableDecl d, Functor f) => Name f A -> LocalState -> M (F ([String], d))
+resolveName :: (ExportableDecl d, Functor f) => Name f A -> LocalState -> M (F d)
 resolveName n = resolveSymbol (annot n) (toList $ nameToList n)
 
-resolveSymbol :: (ExportableDecl d) => A -> [String] -> LocalState -> M (F ([String], d))
+resolveSymbol :: (ExportableDecl d) => A -> [String] -> LocalState -> M (F d)
 resolveSymbol a (p : ps) (LocalState {ephemeralScope = ephemeralScope, currentScopePath = currentPath}) = do
   GlobalState {unitInterface = UnitInterface {rootScope = rootScope}} <- get
 
@@ -265,7 +303,7 @@ resolveSymbol a (p : ps) (LocalState {ephemeralScope = ephemeralScope, currentSc
 
   return $
     case matches of
-      [(p, (_, e))] -> Right (toList p, e)
+      [(_, (_, e))] -> Right e
       [] ->
         Left
           [ Diagnostic
@@ -307,7 +345,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                   M ([Directed FiddleDecl Qualified F A], LocalState)
                 doReturn v = return (Directed directives v dann : declsRet, localState')
                 doReturnWith s v = return (Directed directives v dann : declsRet, s)
-                qualify = qualifyPath (currentScopePath localState')
+
                 metadata = directiveToMetadata d
              in case t of
                   UsingDecl {usingName = name} ->
@@ -320,8 +358,10 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                             <$> advanceStage localState'' st
                             <*> pure a
                   PackageDecl _ name body ann ->
-                    let qualifiedName = qualify (nameToList name)
-                        localState'' = modifyCurrentScopePath (pushScope (nameToList name)) localState'
+                    let (qualifiedName, localState'') =
+                          pushPackage
+                            (nameToList name)
+                            localState'
                         decl = ExportedPackageDecl (metadata qualifiedName)
                      in do
                           insertDecl decl
@@ -332,7 +372,10 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                               <$> mapM (advanceStage localState'') body
                               <*> pure ann
                   LocationDecl _ ident expr ann ->
-                    let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
+                    let qualifiedName =
+                          fmap
+                            (const $ identToString ident)
+                            (currentQualifiedPath localState')
                      in do
                           expr' <- advanceStage localState' expr
                           let decl =
@@ -347,7 +390,10 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                               <$> advanceStage localState' expr
                               <*> pure ann
                   BitsDecl _ ident typ ann ->
-                    let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
+                    let qualifiedName =
+                          fmap
+                            (const $ identToString ident)
+                            (currentQualifiedPath localState)
                      in do
                           sizeBits <- getBitTypeDeclaredSize typ
                           let decl =
@@ -362,11 +408,10 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                               <$> advanceStage localState' typ
                               <*> pure ann
                   ObjTypeDecl _ ident body ann ->
-                    let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
-                        localState'' =
-                          modifyCurrentScopePath
-                            (pushScope (NonEmpty.singleton $ identToString ident))
-                            localState'
+                    let (qualifiedName, localState'') =
+                          pushObject
+                            (identToString ident)
+                            localState
                      in do
                           typeSize <- calculateTypeSize =<< resolveOrFail body
                           let decl =
@@ -381,7 +426,10 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                               <$> mapM (advanceStage localState'') body
                               <*> pure ann
                   ObjectDecl _ ident loc typ ann ->
-                    let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
+                    let qualifiedName =
+                          fmap
+                            (const $ identToString ident)
+                            (currentQualifiedPath localState)
                      in do
                           location <- resolveLocationExpression localState' loc
                           typ' <- advanceStage localState' typ
@@ -414,10 +462,8 @@ objTypeToExport ls = \case
       <$> objTypeToExport ls objType
       <*> pure (trueValue size)
   ReferencedObjType {refName = n} -> do
-    (full, _ :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls
-    case full of
-      (f : fs) -> return $ ReferencedObjectType (f :| fs)
-      _ -> compilationFailure
+    (td :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls
+    return $ ReferencedObjectType (metadataFullyQualifiedPath $ getMetadata td)
 
 calculateTypeSize :: ObjTypeBody Expanded F A -> M (N Bytes)
 calculateTypeSize (ObjTypeBody bodyType decls _) =
@@ -446,7 +492,7 @@ resolveLocationExpression ::
   Expression u stage F A ->
   M (N u)
 resolveLocationExpression ls (Var var _) = do
-  (_, ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls
+  (ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls
   return (fromIntegral v)
 resolveLocationExpression _ e = expressionToIntM e