Change register identifiers to Guarantee a value in qualification.

This remove the burden of generating names from the backend.

6 files changed, 91 insertions, 13 deletions

diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs
index 1ab943f..8ffd83b 100644
--- a/src/Language/Fiddle/Ast/Internal/Instances.hs
+++ b/src/Language/Fiddle/Ast/Internal/Instances.hs
@@ -81,16 +81,51 @@ class
 type TreeType (t :: StagedSynTree) (s :: Stage) =
   t s (StageFunctor s) (StageAnnotation s)
 
+-- | 'StageConvertible' is a typeclass that defines how to convert between
+--   different representations of a syntax tree or its components within a
+--   specific compilation stage.
+--
+--   This typeclass is particularly useful when performing transformations
+--   between different types while staying within the context of a particular
+--   stage of the compilation pipeline. It allows a value of type 'from' to be
+--   converted to a value of type 'to', with the transformation potentially
+--   depending on the current stage's local state and annotation.
+--
+--   The parameters of 'StageConvertible' include:
+--   * 'stage' - The current compilation stage, which influences how the
+--     conversion is performed.
+--   * 'from' - The source type to be converted.
+--   * 'to' - The target type after conversion.
+--
+--   The conversion process is performed using the 'convertInStage' method,
+--   which takes a proxy for the current stage, the annotation type associated
+--   with the stage, and the local state for the stage. It then converts the
+--   source value to the target type within the monadic context of the stage.
 class
   (CompilationStage stage) =>
   StageConvertible stage from to
   where
+  -- | 'convertInStage' performs the conversion from the 'from' type to the 'to'
+  --   type within the given stage.
+  --
+  --   This function takes:
+  --   * 'proxy stage' - A proxy representing the current stage of the compilation.
+  --   * 'StageAnnotation stage' - The annotation associated with the current
+  --     stage, which may provide additional context for the conversion.
+  --     For derived instance of AdvanceStage, this holds the annotation for the
+  --     element being advanced.
+  --   * 'StageState stage' - The local state for the current stage, which may
+  --     influence the transformation.
+  --   * 'from' - The value to be converted.
+  --
+  --   It returns a monadic action within 'StageMonad stage' that produces the
+  --   converted value of type 'to'.
   convertInStage ::
     proxy stage ->
-    StageAnnotation stage ->
-    StageState stage ->
-    from ->
-    StageMonad stage to
+    StageAnnotation stage -> -- Annotation associated with the current stage
+    StageState stage -> -- Local state for the current stage
+    from -> -- The source value to be converted
+    StageMonad stage to -- The resulting converted value
 
 instance (CompilationStage s, Applicative (StageMonad s)) => StageConvertible s a a where
   convertInStage _ _ _ = pure
diff --git a/src/Language/Fiddle/Ast/Internal/MetaTypes.hs b/src/Language/Fiddle/Ast/Internal/MetaTypes.hs
index 7e5e9da..b2fdb26 100644
--- a/src/Language/Fiddle/Ast/Internal/MetaTypes.hs
+++ b/src/Language/Fiddle/Ast/Internal/MetaTypes.hs
@@ -11,6 +11,8 @@ module Language.Fiddle.Ast.Internal.MetaTypes
     module X, -- Re-exporting some commonly used modules
     Guaranteed(..),
     guarantee,
+    guaranteeM,
+    revokeGuarantee
   )
 where
 
@@ -118,9 +120,28 @@ data Guaranteed (s :: Bool) t where
   --   in a 'Maybe'.
   Guaranteed :: t -> Guaranteed True t
 
-guarantee :: t -> Guaranteed s t -> Guaranteed True t
+-- | 'guaranteeM' takes a monadic action and a 'Guaranteed' value that may or 
+-- may not hold a value ('Guaranteed False'). If the input contains a value 
+-- ('Perhaps (Just t)'), it simply wraps that value in 'Guaranteed True'. 
+-- Otherwise, it performs the monadic action to produce a new value and wraps 
+-- it in 'Guaranteed True'.
+guaranteeM :: (Monad m) => m t -> Guaranteed False t -> m (Guaranteed True t)
+guaranteeM _ (Perhaps (Just t)) = return (Guaranteed t)
+guaranteeM act _ = Guaranteed <$> act
+
+-- | 'guarantee' converts a 'Guaranteed False' value to 'Guaranteed True', 
+-- providing a fallback value. If the original 'Guaranteed False' value 
+-- contains a value, that value is used. Otherwise, the fallback value is used.
+guarantee :: t -> Guaranteed False t -> Guaranteed True t
 guarantee v = Guaranteed . fromMaybe v . toMaybe
 
+-- | 'revokeGuarantee' converts a 'Guaranteed True' value back to 
+-- 'Guaranteed False'. It wraps the contained value in 'Perhaps' to indicate 
+-- that the guarantee is no longer present.
+revokeGuarantee :: Guaranteed True t -> Guaranteed False t
+revokeGuarantee = Perhaps . toMaybe
+
+
 instance Functor (Guaranteed s) where
   fmap _ (Perhaps Nothing) = Perhaps Nothing
   fmap f (Perhaps (Just t)) = Perhaps (Just (f t))
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 6f67149..610fdb2 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -452,8 +452,10 @@ data ObjTypeDecl stage f a where
       regOffset :: RegisterOffset stage,
       -- | Optional register modifier.
       regModifier :: Maybe (Modifier f a),
-      -- | Optional register identifier.
-      regIdent :: Maybe (Identifier f a),
+      -- | Optional register identifier. This is guaranteed to exist after
+      -- Qualification, where a generated identifier will be provided if it
+      -- doesn't exist.
+      regIdent :: Guaranteed (stage .>= Qualified) (Identifier f a),
       -- | Size of the register.
       regSize :: Expression stage f a,
       -- | Optional register body.
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index ca97fc4..11a68be 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -91,7 +91,7 @@ instance AdvanceStage CurrentStage ObjTypeDecl where
     return
       . case t of
         TypeSubStructure {subStructureName = (Just n)} -> pushId n
-        RegisterDecl {regIdent = (Just n)} -> pushId n
+        RegisterDecl {regIdent = (Perhaps (Just n))} -> pushId n
         _ -> id
 
 instance AdvanceStage CurrentStage FiddleDecl where
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index 0f7158d..e09725e 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -17,6 +17,7 @@ import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty (..), toList)
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Maybe (mapMaybe)
+import qualified Data.Text
 import Data.Word
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler
@@ -28,8 +29,9 @@ import Text.Printf (printf)
 
 type S = Expanded
 
-newtype GlobalState = GlobalState
-  { unitInterface :: UnitInterface
+data GlobalState = GlobalState
+  { unitInterface :: UnitInterface,
+    uniqueCounter :: Int
   }
 
 data LocalState = LocalState
@@ -43,6 +45,15 @@ type A = Commented SourceSpan
 
 type M = Compile GlobalState
 
+uniqueString :: M String
+uniqueString = do
+  cnt <- gets uniqueCounter
+  modify $ \g -> g {uniqueCounter = cnt + 1}
+  return $ "__anon" ++ show cnt
+
+uniqueIdentifier :: a -> M (Identifier F a)
+uniqueIdentifier a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString
+
 instance CompilationStage Expanded where
   type StageAfter Expanded = Qualified
   type StageMonad Expanded = M
@@ -55,13 +66,22 @@ qualificationPhase =
   pureCompilationPhase $ \t -> do
     raw <-
       fmap snd $
-        subCompile (GlobalState mempty) $
+        subCompile (GlobalState mempty 0) $
           advanceStage
             (LocalState mempty mempty)
             (soakA t)
 
     squeezeDiagnostics raw
 
+-- Any non-guaranteed identifiers are given generated identifiers here.
+instance
+  StageConvertible
+    Expanded
+    (Guaranteed False (Identifier F A))
+    (Guaranteed True (Identifier F A))
+  where
+  convertInStage _ ann _ = guaranteeM (uniqueIdentifier ann)
+
 deriving instance AdvanceStage S ObjTypeBody
 
 deriving instance AdvanceStage S DeferredRegisterBody
@@ -289,7 +309,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
 
 insertDecl :: (ExportableDecl d) => d -> M ()
 insertDecl decl =
-  modify $ \(GlobalState ui) -> GlobalState (UnitInterface.insert decl ui)
+  modify $ \(GlobalState ui c) -> GlobalState (UnitInterface.insert decl ui) c
 
 objTypeToExport :: LocalState -> ObjType Expanded F A -> M ReferencedObjectType
 objTypeToExport ls = \case
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index ebc3d8d..e8f1b62 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -216,7 +216,7 @@ objTypeDeclP =
       <|> ( do
               modifier <- optionMaybe modifierP
               tok_ KWReg
-              RegisterDecl () modifier
+              RegisterDecl () modifier . Perhaps
                 <$> optionMaybe ident
                 <*> exprInParenP
                 <*> optionMaybe (tok TokColon *> registerBodyP)