Make changes to AST for qualification step.

6 files changed, 61 insertions, 36 deletions

diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 8eb8c8e..9c6718c 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -11,6 +11,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     NumberType,
     ImportInterface,
     FiddleUnitInterface,
+    QualificationMetadata,
     -- Witness Types
     Witness (..),
     WitnessType,
@@ -75,6 +76,14 @@ import Language.Fiddle.Internal.UnitInterface (UnitInterface)
 
 type TreeType t stage = t stage (StageFunctor stage) (StageAnnotation stage)
 
+type FullyQualifiedName = String
+
+type family QualificationMetadata stage t where
+  QualificationMetadata stage t =
+    If (stage < Qualified) () t
+
+-- | The type attached to import statements which describe the imported file's
+-- unit interface
 type family FiddleUnitInterface (s :: Stage) :: Type where
   FiddleUnitInterface s = If (s < Checked) () UnitInterface
 
@@ -328,7 +337,10 @@ data FiddleDecl :: StagedSynTree where
     FiddleDecl stage f a
   -- | A using declaration.
   UsingDecl ::
-    { -- | The name being used.
+    { -- Using decls should be removed during qualification.
+      disableUsingDeclAfterQualification :: Witness True, -- TODO change to < Qualified.
+
+      -- | The name being used.
       usingName :: Name f a,
       -- | Annotation for the using declaration.
       usingAnnot :: a
@@ -336,7 +348,9 @@ data FiddleDecl :: StagedSynTree where
     FiddleDecl stage f a
   -- | A package declaration.
   PackageDecl ::
-    { -- | The package name.
+    { -- | Qualification metadata about this package statement.
+      packageQualificationMetadata :: QualificationMetadata stage (),
+      -- | The package name.
       packageName :: Name f a,
       -- | The body of the package.
       packageBody :: f (PackageBody stage f a),
@@ -346,7 +360,9 @@ data FiddleDecl :: StagedSynTree where
     FiddleDecl stage f a
   -- | A location declaration in the form 'location <identifier> = <expr>'.
   LocationDecl ::
-    { -- | The location identifier.
+    { -- | qualified metadata about this location.
+      locationQualificationMetadata :: QualificationMetadata stage (),
+      -- | The location identifier.
       locationIdent :: Identifier f a,
       -- | The associated expression.
       locationExpr :: Expression stage f a,
@@ -356,7 +372,9 @@ data FiddleDecl :: StagedSynTree where
     FiddleDecl stage f a
   -- | A bits declaration in the form 'bits <identifier> : <type>'.
   BitsDecl ::
-    { -- | The identifier of the bits.
+    { -- | Qualification metadata about this "bits" declaration.
+      bitsQualificationMetadata :: QualificationMetadata stage (),
+      -- | The identifier of the bits.
       bitsIdent :: Identifier f a,
       -- | The type of the bits.
       bitsType :: BitType stage f a,
@@ -366,7 +384,9 @@ data FiddleDecl :: StagedSynTree where
     FiddleDecl stage f a
   -- | An object type declaration.
   ObjTypeDecl ::
-    { -- | The identifier of the object type.
+    { -- | Qualification metadata about this object type.
+      objTypeQualificationMetadata :: QualificationMetadata stage (),
+      -- | The identifier of the object type.
       objTypeIdent :: Identifier f a,
       -- | The body of the object type.
       objTypeBody :: f (ObjTypeBody stage f a),
@@ -376,7 +396,9 @@ data FiddleDecl :: StagedSynTree where
     FiddleDecl stage f a
   -- | An object declaration in the form 'object <ident> at <expr> : <type>'.
   ObjectDecl ::
-    { -- | The identifier of the object.
+    { -- | Qualification metadata about this object.
+      objectQualificationMetadata :: QualificationMetadata stage (),
+      -- | The identifier of the object.
       objectIdent :: Identifier f a,
       -- | The location expression.
       objectLocation :: Expression stage f a,
@@ -408,7 +430,7 @@ data ObjType stage f a where
   -- | An anonymous object type, allowed only in Parsed.
   AnonymousObjType ::
     { -- | Witness for stage constraint.
-      anonWitness :: Witness (stage < Expanded),
+      disableAnonymousTypesAfterExpansion :: Witness (stage < Expanded),
       -- | The body of the anonymous type.
       anonBody :: f (ObjTypeBody stage f a),
       -- | Annotation for the anonymous type.
@@ -427,7 +449,8 @@ data ObjType stage f a where
     ObjType stage f a
   -- | A reference to an existing type by name.
   ReferencedObjType ::
-    { -- | The name of the referenced type.
+    { refQualificationMetadata :: QualificationMetadata stage (),
+      -- | The name of the referenced type.
       refName :: Name f a,
       -- | Annotation for the referenced type.
       refAnnot :: a
@@ -441,7 +464,7 @@ data ObjTypeDecl stage f a where
   -- | An assertion statement for a specific position.
   AssertPosStatement ::
     { -- | Witness for stage constraint.
-      assertWitness :: Witness (stage < Checked),
+      disableAssertStatementsAfterConsistencyCheck :: Witness (stage < Checked),
       -- | The expression for the assertion.
       assertExpr :: Expression stage f a,
       -- | Annotation for the assertion.
@@ -586,7 +609,9 @@ data RegisterBitsTypeRef stage f a where
     RegisterBitsTypeRef stage f a
   -- | A reference to another type by name.
   RegisterBitsReference ::
-    { -- | The name of the referenced type.
+    { -- | Qualification metadata about this Bits reference.
+      bitsRefQualificationMetadata :: QualificationMetadata stage (),
+      -- | The name of the referenced type.
       bitsRefName :: Name f a,
       -- | Annotation for the reference.
       bitsRefAnnot :: a
@@ -595,7 +620,7 @@ data RegisterBitsTypeRef stage f a where
   -- | An anonymous type for register bits, used in Parsed.
   RegisterBitsAnonymousType ::
     { -- | Witness for stage constraint.
-      anonBitsWitness :: Witness (stage < Expanded),
+      disableAnonymousBitsAfterExpansion :: Witness (stage < Expanded),
       -- | The anonymous type.
       anonBitsType :: AnonymousBitsType stage f a,
       -- | Annotation for the anonymous type.
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 2f570a4..7ca618b 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -159,18 +159,18 @@ deriving instance AdvanceStage CurrentStage FiddleDecl
 
 instance AdvanceStage CurrentStage (Directed FiddleDecl) where
   modifyState (Directed directives t _) s = case t of
-    (BitsDecl id typ annotation) -> do
+    (BitsDecl () id typ annotation) -> do
       typeSize <- getTypeSize typ
       insertTypeSize annotation s id typeSize
       return s
-    (PackageDecl n _ _) -> do
+    (PackageDecl () n _ _) -> do
       let strs = nameToList n
       let (LocalState scopePath) = s
 
       return $
         LocalState $
           scopePath {currentScope = strs ++ currentScope scopePath}
-    (UsingDecl n _) ->
+    (UsingDecl _ n _) ->
       let (LocalState scopePath) = s
        in return $
             LocalState $
@@ -180,7 +180,7 @@ instance AdvanceStage CurrentStage (Directed FiddleDecl) where
     _ -> return s
 
   customAdvanceStage (Directed directives t a) (LocalState scopePath) = case t of
-    (ObjTypeDecl ident (Identity body) annot) -> do
+    (ObjTypeDecl () ident (Identity body) annot) -> do
       (body', size) <- objTypeBodyToStage3 (LocalState scopePath) body 0
 
       let fullName =
@@ -192,7 +192,7 @@ instance AdvanceStage CurrentStage (Directed FiddleDecl) where
       let ui' = insertIntoUnitInterface fullName ui annot (ExportedObjType size)
       modify' $ \gs -> gs {unitInterface = ui'}
 
-      return $ Just $ Directed directives (ObjTypeDecl ident (Identity body') annot) a
+      return $ Just $ Directed directives (ObjTypeDecl () ident (Identity body') annot) a
     _ -> return Nothing
 
 nameToList :: Name f a -> [String]
@@ -456,8 +456,8 @@ registerBitsTypeRefToStage3 localState = \case
       ( RegisterBitsArray ref' expr' a,
         size * fromIntegral multiplier
       )
-  RegisterBitsReference name a ->
-    (RegisterBitsReference name a,) <$> lookupTypeSize localState name
+  RegisterBitsReference () name a ->
+    (RegisterBitsReference () name a,) <$> lookupTypeSize localState name
   RegisterBitsJustBits expr a -> do
     expr' <- advanceStage localState expr
     (RegisterBitsJustBits expr' a,)
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index f10fa5f..202717f 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -123,8 +123,8 @@ instance AdvanceStage CurrentStage RegisterBitsTypeRef where
         <$> advanceStage path typeref
         <*> advanceStage path expr
         <*> pure annot
-    RegisterBitsReference name annot ->
-      return $ RegisterBitsReference name annot
+    RegisterBitsReference () name annot ->
+      return $ RegisterBitsReference () name annot
     RegisterBitsJustBits expr annot ->
       RegisterBitsJustBits
         <$> advanceStage path expr
@@ -133,16 +133,16 @@ instance AdvanceStage CurrentStage RegisterBitsTypeRef where
       ident <-
         internAnonymousBitsType path
           =<< advanceStage path anonType
-      return $ RegisterBitsReference (identToName ident) annot
+      return $ RegisterBitsReference () (identToName ident) annot
 
 instance AdvanceStage CurrentStage ObjType where
   advanceStage path = \case
     (AnonymousObjType _ (Identity body) annot) -> do
       body' <- advanceStage path body
       identifier <- internObjType path body'
-      return (ReferencedObjType (identToName identifier) annot)
-    (ReferencedObjType name annot) ->
-      return $ ReferencedObjType name annot
+      return (ReferencedObjType () (identToName identifier) annot)
+    (ReferencedObjType () name annot) ->
+      return $ ReferencedObjType () name annot
     (ArrayObjType objType expr a) ->
       ArrayObjType
         <$> advanceStage path objType
@@ -200,12 +200,13 @@ reconfigureFiddleDecls p decls = do
   where
     resolveAnonymousObjType (Linkage linkage, objTypeBody) =
       ObjTypeDecl
+        ()
         (Identifier linkage (annot objTypeBody))
         (pure objTypeBody)
         (annot objTypeBody)
 
     resolveAnonymousBitsType (Linkage linkage, AnonymousEnumBody expr body a) =
-      BitsDecl (Identifier linkage a) (EnumBitType expr body a) a
+      BitsDecl () (Identifier linkage a) (EnumBitType expr body a) a
 
 identToName :: Identifier I a -> Name I a
 identToName ident = Name (NonEmpty.singleton ident) (annot ident)
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index 146fd61..f8fbc0a 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -8,8 +8,6 @@
 --
 -- In this phase, symbol resolution statements (such as 'using' statements) are
 -- removed, as they become unnecessary once references are fully qualified.
--- Additionally, package structures are flattened, and package declarations are
--- discarded since full qualification renders them redundant.
 module Language.Fiddle.Compiler.Qualification (qualificationPhase) where
 
 import Control.Monad.Identity
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index 01549b7..95a730a 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -34,7 +34,8 @@ type Context stage =
     Typeable stage,
     ToGenericSyntaxTreeValue (NumberType stage),
     Show (ImportInterface stage),
-    Show (FiddleUnitInterface stage)
+    Show (FiddleUnitInterface stage),
+    Show (QualificationMetadata stage ())
   )
 
 data GenericSyntaxTree f a where
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index 8dfaaae..a1c7a0e 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -139,15 +139,15 @@ fiddleDeclP = do
     case t of
       KWOption -> OptionDecl <$> nextTextP <*> nextTextP
       KWPackage ->
-        PackageDecl
+        PackageDecl ()
           <$> name
           <*> defer body packageBodyP
-      KWUsing -> UsingDecl <$> name
-      KWLocation -> LocationDecl <$> ident <*> (tok TokEq >> expressionP)
-      KWBits -> BitsDecl <$> ident <*> (tok TokColon >> bitTypeP)
+      KWUsing -> UsingDecl (Witness ()) <$> name
+      KWLocation -> LocationDecl () <$> ident <*> (tok TokEq >> expressionP)
+      KWBits -> BitsDecl () <$> ident <*> (tok TokColon >> bitTypeP)
       KWImport -> ImportDecl <$> importStatementP
       KWType ->
-        ObjTypeDecl
+        ObjTypeDecl ()
           <$> ident
           <*> ( do
                   tok TokColon
@@ -155,7 +155,7 @@ fiddleDeclP = do
                   defer body (objTypeBodyP bt)
               )
       KWInstance ->
-        ObjectDecl
+        ObjectDecl ()
           <$> ident
           <*> (tok KWAt *> expressionP)
           <*> (tok TokColon *> objTypeP)
@@ -181,7 +181,7 @@ objTypeP = do
 
     baseObjP :: P (A -> ObjType Parsed F A)
     baseObjP =
-      (ReferencedObjType <$> name)
+      (ReferencedObjType () <$> name)
         <|> ( do
                 t <- bodyTypeP
                 AnonymousObjType (Witness ()) <$> defer body (objTypeBodyP t)
@@ -281,7 +281,7 @@ registerBitsTypeRefP = do
       withMeta $
         (RegisterBitsJustBits <$> exprInParenP)
           <|> (RegisterBitsAnonymousType (Witness ()) <$> anonymousBitsTypeP)
-          <|> (RegisterBitsReference <$> name)
+          <|> (RegisterBitsReference () <$> name)
 
 anonymousBitsTypeP :: Pa AnonymousBitsType
 anonymousBitsTypeP = withMeta $ do