Replace all the qualification metadata with 'When (s .>= Qualified)'

This makes deriving much easier and cleans up the messy contexts in
GenericTree and elsewhere at the cost of slightly more obtuse syntax.

8 files changed, 61 insertions, 66 deletions

diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs
index 8222174..1ab943f 100644
--- a/src/Language/Fiddle/Ast/Internal/Instances.hs
+++ b/src/Language/Fiddle/Ast/Internal/Instances.hs
@@ -2,6 +2,7 @@ module Language.Fiddle.Ast.Internal.Instances
   ( module X,
     Alter (..),
     AdvanceStage (..),
+    StageConvertible (..),
     CompilationStage (..),
     Annotated (..),
     GAnnot (..),
@@ -94,6 +95,16 @@ class
 instance (CompilationStage s, Applicative (StageMonad s)) => StageConvertible s a a where
   convertInStage _ _ _ = pure
 
+instance
+  ( CompilationStage s,
+    Applicative (StageMonad s),
+    Traversable f,
+    StageConvertible s a b
+  ) =>
+  StageConvertible s (f a) (f b)
+  where
+  convertInStage pxy ann st = mapM (convertInStage pxy ann st)
+
 -- | 'AdvanceStage' defines how to transform an Abstract Syntax Tree (AST) node
 --   from one stage to the next in the compiler pipeline. This transformation
 --   can be customized per node type, or a default generic implementation can be
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 66b8e42..6f67149 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -3,17 +3,16 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Language.Fiddle.Ast.Internal.SyntaxTree
   ( -- Type Families
     NumberType,
-    FiddleUnitInterface,
-    QualificationMetadata,
-    CommonQualificationData (..),
     RegisterOffset,
     BitsOffset,
+    QMd (..),
     -- Witness Types
     Witness (..),
     -- AST Types
@@ -53,29 +52,22 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
 where
 
 import Control.Monad (forM_)
+import Data.Aeson (ToJSON (..))
 import Data.Kind (Type)
 import Data.List.NonEmpty hiding (map)
 import Data.Text (Text)
 import Data.Type.Bool
+import Data.Type.Equality
 import Data.Typeable
 import Data.Word (Word32)
 import GHC.Generics
 import Language.Fiddle.Ast.Internal.Instances
 import Language.Fiddle.Ast.Internal.Kinds
-import Language.Fiddle.Ast.Internal.Stage
 import Language.Fiddle.Ast.Internal.MetaTypes
+import Language.Fiddle.Ast.Internal.Stage
 import Language.Fiddle.Internal.UnitInterface
-import Data.Type.Equality
-import GHC.TypeError as TypeError
-import GHC.TypeLits
-
--- | Common data for each qualified element.
-newtype CommonQualificationData
-  = CommonQualificationData
-  { -- The fully qualified path to this qualified element.
-    fullyQualifiedPath :: [String]
-  }
-  deriving (Eq, Ord, Show)
+
+type QMd s t = When (s .>= Qualified) t
 
 type BitsOffset stage = RegisterOffset stage
 
@@ -85,17 +77,6 @@ type BitsOffset stage = RegisterOffset stage
 type family RegisterOffset stage where
   RegisterOffset stage = If (stage .< Checked) () Word32
 
--- | Type which stores metadata after qualification. Before qualification, this
--- metadata has not been calculated and so is unset.
-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
-
 -- | The Type of number during each stage of compilation. When in the first stage,
 -- numbers are just strings like anything else. In later stages, numbers get
 -- parsed into actual integers. This makes it easier to process later.
@@ -341,7 +322,7 @@ data FiddleDecl :: StagedSynTree where
   PackageDecl ::
     { -- | Qualification metadata about this package statement.
       packageQualificationMetadata ::
-        f (QualificationMetadata stage ExportedPackageDecl),
+        f (QMd stage ExportedPackageDecl),
       -- | The package name.
       packageName :: Name f a,
       -- | The body of the package.
@@ -354,7 +335,7 @@ data FiddleDecl :: StagedSynTree where
   LocationDecl ::
     { -- | qualified metadata about this location.
       locationQualificationMetadata ::
-        f (QualificationMetadata stage ExportedLocationDecl),
+        f (QMd stage ExportedLocationDecl),
       -- | The location identifier.
       locationIdent :: Identifier f a,
       -- | The associated expression.
@@ -366,7 +347,7 @@ data FiddleDecl :: StagedSynTree where
   -- | A bits declaration in the form 'bits <identifier> : <type>'.
   BitsDecl ::
     { -- | Qualification metadata about this "bits" declaration.
-      bitsQualificationMetadata :: f (QualificationMetadata stage ExportedBitsDecl),
+      bitsQualificationMetadata :: f (QMd stage ExportedBitsDecl),
       -- | The identifier of the bits.
       bitsIdent :: Identifier f a,
       -- | The type of the bits.
@@ -378,7 +359,7 @@ data FiddleDecl :: StagedSynTree where
   -- | An object type declaration.
   ObjTypeDecl ::
     { -- | Qualification metadata about this object type.
-      objTypeQualificationMetadata :: f (QualificationMetadata stage ExportedTypeDecl),
+      objTypeQualificationMetadata :: f (QMd stage ExportedTypeDecl),
       -- | The identifier of the object type.
       objTypeIdent :: Identifier f a,
       -- | The body of the object type.
@@ -390,7 +371,7 @@ data FiddleDecl :: StagedSynTree where
   -- | An object declaration in the form 'object <ident> at <expr> : <type>'.
   ObjectDecl ::
     { -- | Qualification metadata about this object.
-      objectQualificationMetadata :: f (QualificationMetadata stage ExportedObjectDecl),
+      objectQualificationMetadata :: f (QMd stage ExportedObjectDecl),
       -- | The identifier of the object.
       objectIdent :: Identifier f a,
       -- | The location expression.
@@ -442,7 +423,7 @@ data ObjType stage f a where
     ObjType stage f a
   -- | A reference to an existing type by name.
   ReferencedObjType ::
-    { refQualificationMetadata :: f (QualificationMetadata stage ExportedTypeDecl),
+    { refQualificationMetadata :: f (QMd stage ExportedTypeDecl),
       -- | The name of the referenced type.
       refName :: Name f a,
       -- | Annotation for the referenced type.
@@ -609,7 +590,7 @@ data RegisterBitsTypeRef stage f a where
   -- | A reference to another type by name.
   RegisterBitsReference ::
     { -- | Qualification metadata about this Bits reference.
-      bitsRefQualificationMetadata :: f (QualificationMetadata stage ExportedBitsDecl),
+      bitsRefQualificationMetadata :: f (QMd stage ExportedBitsDecl),
       -- | The name of the referenced type.
       bitsRefName :: Name f a,
       -- | Annotation for the reference.
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index 5379099..2e6421e 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -265,7 +265,7 @@ transpileWalk sourceFile headerFile t _ = case () of
         withFileAt headerFile middlePos $ do
           pad $ do
             emitDocComments a
-            struct (identifierFor metadata) $ do
+            struct (identifierFor (unwrap metadata)) $ do
               structBody objTypeBody
         return Stop
   _ -> return (Continue ())
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index a4f252e..552ea40 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -35,6 +35,9 @@ type A = Commented SourceSpan
 
 type M = Compile ()
 
+pattern QMdP :: t -> Identity (When True t)
+pattern QMdP t = Identity (Present t)
+
 instance CompilationStage Checked where
   type StageAfter Checked = TypeError (TypeError.Text "No stage after Checked")
   type StageMonad Checked = M
@@ -85,19 +88,19 @@ instance AdvanceStage S FiddleUnit where
       doWalk t =
         case () of
           ()
-            | (Just (PackageDecl {packageQualificationMetadata = (Identity d)})) <-
+            | (Just (PackageDecl {packageQualificationMetadata = (QMdP d)})) <-
                 castTS t ->
                 tell (UnitInterface.singleton d)
-            | (Just (LocationDecl {locationQualificationMetadata = (Identity d)})) <-
+            | (Just (LocationDecl {locationQualificationMetadata = (QMdP d)})) <-
                 castTS t ->
                 tell (UnitInterface.singleton d)
-            | (Just (BitsDecl {bitsQualificationMetadata = (Identity d)})) <-
+            | (Just (BitsDecl {bitsQualificationMetadata = (QMdP d)})) <-
                 castTS t ->
                 tell (UnitInterface.singleton d)
-            | (Just (ObjTypeDecl {objTypeQualificationMetadata = (Identity d)})) <-
+            | (Just (ObjTypeDecl {objTypeQualificationMetadata = (QMdP d)})) <-
                 castTS t ->
                 tell (UnitInterface.singleton d)
-            | (Just (ObjectDecl {objectQualificationMetadata = (Identity d)})) <-
+            | (Just (ObjectDecl {objectQualificationMetadata = (QMdP d)})) <-
                 castTS t ->
                 tell (UnitInterface.singleton d)
             | (Just (ImportStatement {importInterface = ii})) <-
@@ -242,8 +245,9 @@ bitsTypeSize (RegisterBitsArray tr nExpr _) = do
 bitsTypeSize
   RegisterBitsReference
     { bitsRefQualificationMetadata =
-        Identity (ExportedBitsDecl {exportedBitsDeclSizeBits = sz})
+        QMdP (ExportedBitsDecl {exportedBitsDeclSizeBits = sz})
     } = return sz
+bitsTypeSize (RegisterBitsReference {}) = error "should be exhaustive"
 bitsTypeSize (RegisterBitsJustBits expr _) =
   expressionToIntM expr
 
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index 935d8ee..ca97fc4 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -130,14 +130,14 @@ instance AdvanceStage CurrentStage RegisterBitsTypeRef where
       ident <-
         internAnonymousBitsType path
           =<< advanceStage path anonType
-      return $ RegisterBitsReference (pure ()) (identToName ident) annot
+      return $ RegisterBitsReference (Identity Vacant) (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 (pure ()) (identToName identifier) annot)
+      return (ReferencedObjType (Identity Vacant) (identToName identifier) annot)
     (ReferencedObjType q name annot) ->
       return $ ReferencedObjType q name annot
     (ArrayObjType objType expr a) ->
@@ -197,13 +197,13 @@ reconfigureFiddleDecls p decls = do
   where
     resolveAnonymousObjType (Linkage linkage, objTypeBody) =
       ObjTypeDecl
-        (pure ())
+        (Identity Vacant)
         (Identifier linkage (annot objTypeBody))
         (pure objTypeBody)
         (annot objTypeBody)
 
     resolveAnonymousBitsType (Linkage linkage, AnonymousEnumBody expr body a) =
-      BitsDecl (pure ()) (Identifier linkage a) (EnumBitType expr body a) a
+      BitsDecl (Identity Vacant) (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 a39e5dc..0f7158d 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -96,7 +96,7 @@ instance AdvanceStage S RegisterBitsTypeRef where
         <$> advanceStage localState a
         <*> pure b
     RegisterBitsReference _ name a -> do
-      v <- fmap snd <$> resolveName name localState
+      v <- fmap (Present . snd) <$> resolveName name localState
       return $ RegisterBitsReference v name a
 
 instance AdvanceStage S ObjType where
@@ -107,7 +107,7 @@ instance AdvanceStage S ObjType where
         <*> advanceStage localState b
         <*> pure c
     ReferencedObjType _ name a -> do
-      v <- fmap snd <$> resolveName name localState
+      v <- fmap (Present . snd) <$> resolveName name localState
       return $ ReferencedObjType v name a
 
 deriving instance (AdvanceStage S t) => AdvanceStage S (Directed t)
@@ -176,6 +176,9 @@ resolveSymbol a (p : ps) (LocalState {ephemeralScope = ephemeralScope, currentSc
 resolveSymbol a _ _ =
   return $ Left [Diagnostic Error "Empty path provided (this is a bug)" (unCommented a)]
 
+qMd :: (Applicative f) => t -> f (QMd Qualified t)
+qMd = pure . Present
+
 advanceFiddleDecls ::
   LocalState ->
   [Directed FiddleDecl S F A] ->
@@ -213,7 +216,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                           insertDecl decl
                           doReturn
                             =<< PackageDecl
-                              (pure decl)
+                              (qMd decl)
                               name
                               <$> mapM (advanceStage localState'') body
                               <*> pure ann
@@ -228,7 +231,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                           insertDecl decl
                           doReturn
                             =<< LocationDecl
-                              (pure decl)
+                              (qMd decl)
                               ident
                               <$> advanceStage localState' expr
                               <*> pure ann
@@ -243,7 +246,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                           insertDecl decl
                           doReturn
                             =<< BitsDecl
-                              (pure decl)
+                              (qMd decl)
                               ident
                               <$> advanceStage localState' typ
                               <*> pure ann
@@ -258,7 +261,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                           insertDecl decl
                           doReturn
                             =<< ObjTypeDecl
-                              (pure decl)
+                              (qMd decl)
                               ident
                               <$> mapM (advanceStage localState') body
                               <*> pure ann
@@ -275,7 +278,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                           insertDecl decl
                           doReturn
                             =<< ObjectDecl
-                              (pure decl)
+                              (qMd decl)
                               ident
                               <$> advanceStage localState' loc
                               <*> advanceStage localState' typ
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index 694b3ab..9b04ac7 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -31,14 +31,7 @@ type Context stage =
   ( Show (NumberType stage),
     Typeable stage,
     ToJSON (NumberType stage),
-    ToJSON (RegisterOffset stage),
-    ToJSON (FiddleUnitInterface stage),
-    ToJSON (QualificationMetadata stage ()),
-    ToJSON (QualificationMetadata stage ExportedPackageDecl),
-    ToJSON (QualificationMetadata stage ExportedLocationDecl),
-    ToJSON (QualificationMetadata stage ExportedBitsDecl),
-    ToJSON (QualificationMetadata stage ExportedTypeDecl),
-    ToJSON (QualificationMetadata stage ExportedObjectDecl)
+    ToJSON (RegisterOffset stage)
   )
 
 class FunctorShow f where
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index f3cbfee..ebc3d8d 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -30,6 +30,9 @@ type Pa (a :: Stage -> (Type -> Type) -> Type -> Type) = P (a 'Parsed F (Comment
 
 type PaS (a :: (Type -> Type) -> Type -> Type) = P (a F (Commented SourceSpan))
 
+noQMd :: F (QMd Parsed t)
+noQMd = pure Vacant
+
 commentP :: P Comment
 commentP =
   token $ \case
@@ -139,15 +142,15 @@ fiddleDeclP = do
     case t of
       KWOption -> OptionDecl <$> nextTextP <*> nextTextP
       KWPackage ->
-        PackageDecl (pure ())
+        PackageDecl noQMd
           <$> name
           <*> defer body packageBodyP
       KWUsing -> UsingDecl Witness <$> name
-      KWLocation -> LocationDecl (pure ()) <$> ident <*> (tok TokEq >> expressionP)
-      KWBits -> BitsDecl (pure ()) <$> ident <*> (tok TokColon >> bitTypeP)
+      KWLocation -> LocationDecl noQMd <$> ident <*> (tok TokEq >> expressionP)
+      KWBits -> BitsDecl noQMd <$> ident <*> (tok TokColon >> bitTypeP)
       KWImport -> ImportDecl <$> importStatementP
       KWType ->
-        ObjTypeDecl (pure ())
+        ObjTypeDecl noQMd
           <$> ident
           <*> ( do
                   tok_ TokColon
@@ -155,7 +158,7 @@ fiddleDeclP = do
                   defer body (objTypeBodyP bt)
               )
       KWInstance ->
-        ObjectDecl (pure ())
+        ObjectDecl noQMd
           <$> ident
           <*> (tok KWAt *> expressionP)
           <*> (tok TokColon *> objTypeP)
@@ -181,7 +184,7 @@ objTypeP = do
 
     baseObjP :: P (A -> ObjType Parsed F A)
     baseObjP =
-      (ReferencedObjType (pure ()) <$> name)
+      (ReferencedObjType noQMd <$> name)
         <|> ( do
                 t <- bodyTypeP
                 AnonymousObjType Witness <$> defer body (objTypeBodyP t)
@@ -281,7 +284,7 @@ registerBitsTypeRefP = do
       withMeta $
         (RegisterBitsJustBits <$> exprInParenP)
           <|> (RegisterBitsAnonymousType Witness <$> anonymousBitsTypeP)
-          <|> (RegisterBitsReference (pure ()) <$> name)
+          <|> (RegisterBitsReference noQMd <$> name)
 
 anonymousBitsTypeP :: Pa AnonymousBitsType
 anonymousBitsTypeP = withMeta $ do