Change the AST to use Names instead of Identifiers for ObjDecls and BitsDecls

This is to make anonymous expansion better and cleaner. It gets rid of
the hash-mark hack introduced earlier.

6 files changed, 91 insertions, 63 deletions

diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 063913b..c539665 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -410,8 +410,9 @@ data FiddleDecl :: StagedSynTree where
   BitsDecl ::
     { -- | Qualification metadata about this "bits" declaration.
       bitsQualificationMetadata :: f (QMd stage ExportedBitsDecl),
-      -- | The identifier of the bits.
-      bitsIdent :: Identifier f a,
+      -- | The identifier of the bits. When initially parsed, this can only be
+      -- an Identifier, but during compilation this may change to a "name".
+      bitsName :: Name f a,
       -- | The type of the bits.
       bitsType :: BitType stage f a,
       -- | Annotation for the bits declaration.
@@ -423,7 +424,7 @@ data FiddleDecl :: StagedSynTree where
     { -- | Qualification metadata about this object type.
       objTypeQualificationMetadata :: f (QMd stage ExportedTypeDecl),
       -- | The identifier of the object type.
-      objTypeIdent :: Identifier f a,
+      objTypeIdent :: Name f a,
       -- | The body of the object type.
       objTypeBody :: f (ObjTypeBody stage f a),
       -- | Annotation for the object type declaration.
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index f4132c6..79c81b1 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -284,7 +284,13 @@ writeRegSet
             tell $ Text.pack $ printf "  o->%s[%d] = in[%d];\n" fieldName i i
           tell "}\n\n"
 
-pattern DefinedBitsP :: Modifier f a -> String -> QualifiedPath String -> N Bits -> RegisterBitsTypeRef Checked f a -> RegisterBitsDecl Checked f a
+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 =
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index 0443b8d..5e7063e 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -10,6 +10,7 @@ import Control.Monad.Identity (Identity (..))
 import Control.Monad.State (get, modify, put)
 import qualified Data.Char as Char
 import Data.List (intercalate)
+import Data.List.NonEmpty (NonEmpty, (<|))
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Text (Text)
 import qualified Data.Text as Text
@@ -25,15 +26,10 @@ type Annot = Commented SourceSpan
 
 type CurrentStage = ImportsResolved
 
-newtype Path = Path [PathExpression]
-
-newtype PathExpression = PathExpression String
-
-joinPath :: Path -> String
-joinPath (Path l) = intercalate "#" $ reverse (map (\(PathExpression s) -> s) l)
+type Path = [Text]
 
 expandAst :: FiddleUnit CurrentStage I Annot -> Compile () (FiddleUnit Expanded I Annot)
-expandAst = fmap snd . subCompile (State [] []) . advanceStage (Path mempty)
+expandAst = fmap snd . subCompile (State [] []) . advanceStage mempty
 
 expansionPhase :: CompilationPhase CurrentStage Expanded
 expansionPhase = CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _ -> expandAst)
@@ -41,7 +37,7 @@ expansionPhase = CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _
 -- Shorthand for Identity
 type I = Identity
 
-newtype Linkage = Linkage Text deriving (Show)
+newtype Linkage = Linkage (NonEmpty Text) deriving (Show)
 
 data State
   = State
@@ -100,9 +96,9 @@ instance AdvanceStage CurrentStage FiddleDecl where
   modifyState t =
     return
       . case t of
-        PackageDecl {packageName = n} -> pushName n
-        BitsDecl {bitsIdent = i} -> pushId i
-        ObjTypeDecl {objTypeIdent = i} -> pushId i
+        -- PackageDecl {packageName = n} -> pushName n
+        BitsDecl {bitsName = n} -> pushName n
+        ObjTypeDecl {objTypeIdent = i} -> pushName i
         ObjectDecl {objectIdent = i} -> pushId i
         _ -> id
 
@@ -130,17 +126,17 @@ instance AdvanceStage CurrentStage RegisterBitsTypeRef where
         <$> advanceStage path expr
         <*> pure annot
     RegisterBitsAnonymousType _ anonType annot -> do
-      ident <-
+      name <-
         internAnonymousBitsType path
           =<< advanceStage path anonType
-      return $ RegisterBitsReference (Identity Vacant) (identToName ident) annot
+      return $ RegisterBitsReference (Identity Vacant) name annot
 
 instance AdvanceStage CurrentStage ObjType where
   advanceStage path = \case
     (AnonymousObjType _ (Identity body) annot) -> do
       body' <- advanceStage path body
-      identifier <- internObjType path body'
-      return (ReferencedObjType (Identity Vacant) (identToName identifier) annot)
+      name <- internObjType path body'
+      return (ReferencedObjType (Identity Vacant) name annot)
     (ReferencedObjType q name annot) ->
       return $ ReferencedObjType q name annot
     (ArrayObjType objType expr a) ->
@@ -202,39 +198,43 @@ reconfigureFiddleDecls p decls = do
     resolveAnonymousObjType (Linkage linkage, objTypeBody) =
       ObjTypeDecl
         (Identity Vacant)
-        (Identifier linkage (annot objTypeBody))
+        (Name (fmap (\t -> Identifier t (annot objTypeBody)) (NonEmpty.reverse linkage)) (annot objTypeBody))
         (pure objTypeBody)
         (annot objTypeBody)
 
     resolveAnonymousBitsType (Linkage linkage, AnonymousEnumBody expr body a) =
-      BitsDecl (Identity Vacant) (Identifier linkage a) (EnumBitType expr body a) a
+      BitsDecl
+        (Identity Vacant)
+        (Name (fmap (\t -> Identifier t a) (NonEmpty.reverse linkage)) a)
+        (EnumBitType expr body a)
+        a
 
 identToName :: Identifier I a -> Name I a
 identToName ident = Name (NonEmpty.singleton ident) (annot ident)
 
-internObjType :: Path -> ObjTypeBody Expanded I Annot -> M (Identifier I Annot)
-internObjType path body =
-  let str = Text.pack $ joinPath path
-   in do
-        modify $ \(State objTypeBodies a) ->
-          State ((Linkage str, body) : objTypeBodies) a
-        return (Identifier str (annot body))
+internObjType :: Path -> ObjTypeBody Expanded I Annot -> M (Name I Annot)
+internObjType [] _ = compilationFailure
+internObjType (NonEmpty.fromList -> path) body =
+  do
+    modify $ \(State objTypeBodies a) ->
+      State ((Linkage path, body) : objTypeBodies) a
+    let a = annot body
+     in return (Name (fmap (\t -> Identifier t a) (NonEmpty.reverse path)) a)
 
 internAnonymousBitsType ::
   Path ->
   AnonymousBitsType Expanded I Annot ->
-  M (Identifier I Annot)
-internAnonymousBitsType path anonymousBitsType =
-  let str = Text.pack $ joinPath path
-   in do
-        modify $ \(State a anonymousBitsTypes) ->
-          State a ((Linkage str, anonymousBitsType) : anonymousBitsTypes)
-        return (Identifier str (annot anonymousBitsType))
+  M (Name I Annot)
+internAnonymousBitsType [] _ = compilationFailure
+internAnonymousBitsType (NonEmpty.fromList -> path) anonymousBitsType =
+  do
+    modify $ \(State a anonymousBitsTypes) ->
+      State a ((Linkage path, anonymousBitsType) : anonymousBitsTypes)
+    let a = annot anonymousBitsType
+     in return (Name (fmap (\t -> Identifier t a) (NonEmpty.reverse path)) a)
 
 pushId :: Identifier f a -> Path -> Path
-pushId (Identifier str _) (Path lst) =
-  Path (PathExpression (Text.unpack str) : lst)
+pushId (Identifier str _) lst = str : lst
 
 pushName :: Name f a -> Path -> Path
-pushName (Name idents _) path =
-  foldl (flip pushId) path idents
+pushName (Name idents _) path = foldl (flip pushId) path idents
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index 1307c2a..81e6ac4 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -1,4 +1,4 @@
--- | Qualification compilation phase.
+-- | Qualification compilation pha se.
 --
 -- The qualification phase is responsible for resolving all type references in
 -- the AST to their fully-qualified counterparts. This process involves
@@ -82,18 +82,36 @@ pushPackage pk ls =
       let q = currentQualifiedPath ls
        in q {packagePart = packagePart q ++ h, basenamePart = l}
 
-pushObject :: String -> LocalState -> (QualifiedPath String, LocalState)
-pushObject objName ls =
+pushObject :: NonEmpty String -> LocalState -> (QualifiedPath String, LocalState)
+pushObject obj ls =
   let q = currentQualifiedPath ls
-   in ( fmap (const objName) q,
+   in ( qualifyObject obj,
         ls
-          { currentScopePath = pushScope (NonEmpty.singleton objName) (currentScopePath ls),
+          { currentScopePath = pushScope obj (currentScopePath ls),
             currentQualifiedPath =
               q
-                { objectPart = Just objName
+                { objectPart = objectPart q ++ NonEmpty.toList obj
                 }
           }
       )
+  where
+    qualifyObject :: NonEmpty String -> QualifiedPath String
+    qualifyObject (NonEmpty.reverse -> (l :| (reverse -> h))) =
+      let q = currentQualifiedPath ls
+       in q {objectPart = objectPart 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 = objName
+--                 }
+--           }
+--       )
 
 pushRegister :: String -> LocalState -> (QualifiedPath String, LocalState)
 pushRegister regName ls =
@@ -103,14 +121,14 @@ pushRegister regName ls =
           { currentScopePath = pushScope (NonEmpty.singleton regName) (currentScopePath ls),
             currentQualifiedPath =
               q
-                { registerPart = registerPart q  ++ [regName]
+                { registerPart = registerPart q ++ [regName]
                 }
           }
       )
 
 qualificationPhase :: CompilationPhase Expanded Qualified
 qualificationPhase =
-  let initialQualifiedPath = QualifiedPath [] Nothing [] ()
+  let initialQualifiedPath = QualifiedPath [] [] [] ()
    in pureCompilationPhase $ \t -> do
         raw <-
           fmap snd $
@@ -162,7 +180,7 @@ instance AdvanceStage S RegisterBitsDecl where
         <*> pure name
         <*> pure an
     DefinedBits _ mod ident typ an -> do
-      let (path, _) = pushObject (identToString ident) localState
+      let (path, _) = pushRegister (identToString ident) localState
           qMeta =
             QBitsMetadata
               { bitsSpan = Vacant,
@@ -389,11 +407,11 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                               ident
                               <$> advanceStage localState' expr
                               <*> pure ann
-                  BitsDecl _ ident typ ann ->
-                    let qualifiedName =
-                          fmap
-                            (const $ identToString ident)
-                            (currentQualifiedPath localState)
+                  BitsDecl _ name@(Name ids _) typ ann ->
+                    let (qualifiedName, _) =
+                          pushObject
+                            (fmap identToString ids)
+                            localState
                      in do
                           sizeBits <- getBitTypeDeclaredSize typ
                           let decl =
@@ -404,13 +422,13 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                           doReturn
                             =<< BitsDecl
                               (qMd decl)
-                              ident
+                              name
                               <$> advanceStage localState' typ
                               <*> pure ann
-                  ObjTypeDecl _ ident body ann ->
+                  ObjTypeDecl _ name@(Name ids _) body ann ->
                     let (qualifiedName, localState'') =
                           pushObject
-                            (identToString ident)
+                            (fmap identToString ids)
                             localState
                      in do
                           typeSize <- calculateTypeSize =<< resolveOrFail body
@@ -422,7 +440,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                           doReturn
                             =<< ObjTypeDecl
                               (qMd decl)
-                              ident
+                              name
                               <$> mapM (advanceStage localState'') body
                               <*> pure ann
                   ObjectDecl _ ident loc typ ann ->
diff --git a/src/Language/Fiddle/Internal/UnitInterface.hs b/src/Language/Fiddle/Internal/UnitInterface.hs
index 1302e40..26b0875 100644
--- a/src/Language/Fiddle/Internal/UnitInterface.hs
+++ b/src/Language/Fiddle/Internal/UnitInterface.hs
@@ -41,7 +41,7 @@ data QualifiedPath a = QualifiedPath
   { -- | The part of the qualified path that belongs to the package.
     packagePart :: [String],
     -- | The part of the qualified path that belongs to the object.
-    objectPart :: Maybe String,
+    objectPart :: [String],
     -- | The part of the qualified path that belongs to a register.
     registerPart :: [String],
     -- | The basename (unqualified path)
@@ -56,7 +56,7 @@ qualifiedPathToString majorSeparator minorSeparator qp =
       filter
         (not . null)
         [ packagePart qp,
-          maybeToList (objectPart qp),
+          objectPart qp,
           registerPart qp,
           [basenamePart qp]
         ]
@@ -64,7 +64,7 @@ qualifiedPathToString majorSeparator minorSeparator qp =
 -- | Turn a QualifiedPath with a string to a String list for scope lookups.
 qualifiedPathToList :: QualifiedPath String -> NonEmpty String
 qualifiedPathToList (QualifiedPath package obj reg base) =
-  NonEmpty.prependList (package ++ maybeToList obj ++ reg) (NonEmpty.singleton base)
+  NonEmpty.prependList (package ++ obj ++ reg) (NonEmpty.singleton base)
 
 -- | Metadata about an exported value. This includes things like the source
 -- location, doc comments and compiler directives associated with the exported
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index 7ef5ac4..ad96724 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -135,6 +135,9 @@ importStatementP =
       <*> optionMaybe importListP
       <*> pure Vacant
 
+nameToIdent :: PaS Identifier -> PaS Name
+nameToIdent ifn = withMeta $ Name . pure <$> ident
+
 fiddleDeclP :: Pa FiddleDecl
 fiddleDeclP = do
   withMeta $ do
@@ -147,11 +150,11 @@ fiddleDeclP = do
           <*> defer body packageBodyP
       KWUsing -> UsingDecl Witness <$> name
       KWLocation -> LocationDecl noQMd <$> ident <*> (tok TokEq >> constExpressionP)
-      KWBits -> BitsDecl noQMd <$> ident <*> (tok TokColon >> bitTypeP)
+      KWBits -> BitsDecl noQMd <$> nameToIdent ident <*> (tok TokColon >> bitTypeP)
       KWImport -> ImportDecl <$> importStatementP
       KWType ->
         ObjTypeDecl noQMd
-          <$> ident
+          <$> nameToIdent ident
           <*> ( do
                   tok_ TokColon
                   bt <- bodyTypeP
@@ -190,7 +193,7 @@ objTypeP = do
                 AnonymousObjType Witness <$> defer body (objTypeBodyP t)
             )
 
-asConstP ::  Pa (Expression u) -> Pa (ConstExpression u)
+asConstP :: Pa (Expression u) -> Pa (ConstExpression u)
 asConstP fn = withMeta $ ConstExpression . RightV <$> fn
 
 exprInParenP :: Pa (Expression u)