Wip: added -Wall

6 files changed, 66 insertions, 23 deletions

diff --git a/package.yaml b/package.yaml
index 217a741..62bbdf8 100644
--- a/package.yaml
+++ b/package.yaml
@@ -31,6 +31,8 @@ ghc-options:
   - -XTypeOperators
   - -XUndecidableInstances
   - -XViewPatterns
+  - -Wall
+  - -fno-warn-orphans
 
 dependencies:
   - base >= 4.0.0
diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs
index 379c788..3380ccd 100644
--- a/src/Language/Fiddle/Ast/Internal/Instances.hs
+++ b/src/Language/Fiddle/Ast/Internal/Instances.hs
@@ -7,6 +7,7 @@ module Language.Fiddle.Ast.Internal.Instances
     CompilationStage (..),
     Annotated (..),
     GAnnot (..),
+    TreeType (..),
   )
 where
 
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 9c6718c..6aa0793 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -43,7 +43,6 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     EnumBody (..),
     EnumConstantDecl (..),
     PackageBody (..),
-    TreeType (..),
     -- Helper Functions
     mapDirected,
     mapDirectedM,
@@ -51,6 +50,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     undirected,
     -- Utility Functions
     squeeze,
+    nameToList,
   )
 where
 
@@ -58,7 +58,7 @@ import Control.Monad (forM_)
 import Data.Coerce
 import Data.Functor.Identity
 import Data.Kind (Type)
-import Data.List.NonEmpty
+import Data.List.NonEmpty hiding (map)
 import Data.Proxy
 import Data.Text (Text)
 import Data.Traversable
@@ -73,14 +73,19 @@ import Language.Fiddle.Ast.Internal.Instances
 import Language.Fiddle.Ast.Internal.Kinds
 import Language.Fiddle.Ast.Internal.Stage
 import Language.Fiddle.Internal.UnitInterface (UnitInterface)
+import qualified Data.Text as Text
 
-type TreeType t stage = t stage (StageFunctor stage) (StageAnnotation stage)
-
-type FullyQualifiedName = String
+-- | Common data for each qualified element.
+newtype CommonQualifcationData
+  = CommonQualifcationData
+  { -- The fully qualified path to this qualified element.
+    fullyQualifiedPath :: [String]
+  }
+  deriving (Eq, Ord, Show)
 
 type family QualificationMetadata stage t where
   QualificationMetadata stage t =
-    If (stage < Qualified) () t
+    If (stage < Qualified) () (CommonQualifcationData, t)
 
 -- | The type attached to import statements which describe the imported file's
 -- unit interface
@@ -718,3 +723,6 @@ data PackageBody (stage :: Stage) (f :: Type -> Type) a where
 
 squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a)
 squeeze = alter (fmap Identity) return
+
+nameToList :: Name f a -> [String]
+nameToList (Name ids _) = map (Text.unpack . identifierName) (toList ids)
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 7ca618b..79ac9e7 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -159,11 +159,11 @@ 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
 
@@ -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 q ident (Identity body) annot) -> do
       (body', size) <- objTypeBodyToStage3 (LocalState scopePath) body 0
 
       let fullName =
@@ -192,12 +192,9 @@ 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 q ident (Identity body') annot) a
     _ -> return Nothing
 
-nameToList :: Name f a -> [String]
-nameToList (Name idents _) = map (\(Identifier (Text.unpack -> s) _) -> s) (toList idents)
-
 objTypeBodyToStage3 ::
   LocalState ->
   ObjTypeBody CurrentStage I Annot ->
@@ -456,8 +453,8 @@ registerBitsTypeRefToStage3 localState = \case
       ( RegisterBitsArray ref' expr' a,
         size * fromIntegral multiplier
       )
-  RegisterBitsReference () name a ->
-    (RegisterBitsReference () name a,) <$> lookupTypeSize localState name
+  RegisterBitsReference q name a ->
+    (RegisterBitsReference q name a,) <$> lookupTypeSize localState name
   RegisterBitsJustBits expr a -> do
     expr' <- advanceStage localState expr
     (RegisterBitsJustBits expr' a,)
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index f8fbc0a..27c0911 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -10,7 +10,10 @@
 -- removed, as they become unnecessary once references are fully qualified.
 module Language.Fiddle.Compiler.Qualification (qualificationPhase) where
 
+import Control.Monad (forM)
 import Control.Monad.Identity
+import Data.Foldable (foldlM)
+import Data.Maybe (catMaybes)
 import Data.Word
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler
@@ -69,18 +72,36 @@ deriving instance AdvanceStage CurrentStage EnumConstantDecl
 
 deriving instance AdvanceStage CurrentStage RegisterBitsDecl
 
-deriving instance AdvanceStage CurrentStage PackageBody
-
 deriving instance AdvanceStage CurrentStage ObjTypeDecl
 
-deriving instance AdvanceStage CurrentStage FiddleDecl
-
-deriving instance AdvanceStage CurrentStage FiddleUnit
-
 deriving instance AdvanceStage CurrentStage Expression
 
-deriving instance AdvanceStage CurrentStage RegisterBitsTypeRef
+instance AdvanceStage CurrentStage RegisterBitsTypeRef where
+  advanceStage = undefined
 
-deriving instance AdvanceStage CurrentStage ObjType
+instance AdvanceStage CurrentStage ObjType where
+  advanceStage = undefined
 
 deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t)
+
+instance AdvanceStage CurrentStage PackageBody where
+  advanceStage localState (PackageBody decls annot) =
+    PackageBody <$> advanceFiddleDecls localState decls <*> pure annot
+
+instance AdvanceStage CurrentStage FiddleUnit where
+  advanceStage localState (FiddleUnit () decls annot) =
+    FiddleUnit () <$> advanceFiddleDecls localState decls <*> pure annot
+
+advanceFiddleDecls ::
+  LocalState ->
+  [TreeType (Directed FiddleDecl) CurrentStage] ->
+  (StageMonad CurrentStage)
+    [TreeType (Directed FiddleDecl) Qualified]
+advanceFiddleDecls (LocalState scopePath) decls = fmap (reverse . fst) $ do
+  foldlM
+    ( \(declsRet, scopePath') -> \case
+        Directed {directedSubtree = UsingDecl {usingName = name}} ->
+          return (declsRet, addUsingPath (nameToList name) scopePath')
+    )
+    ([], scopePath)
+    decls
diff --git a/src/Language/Fiddle/Internal/Scopes.hs b/src/Language/Fiddle/Internal/Scopes.hs
index ac6f7d1..02c9a5a 100644
--- a/src/Language/Fiddle/Internal/Scopes.hs
+++ b/src/Language/Fiddle/Internal/Scopes.hs
@@ -29,6 +29,20 @@ data ScopePath k = ScopePath
   }
   deriving (Eq, Ord, Show, Read)
 
+-- | Qualify a name with the current scope.
+qualifyPath :: ScopePath k -> k -> [k]
+qualifyPath ScopePath {currentScope = scope} k = scope ++ [k]
+
+-- | Push a new scope onto the current scope.
+pushScope :: k -> ScopePath k -> ScopePath k
+pushScope v s@ScopePath {currentScope = scope} =
+  s {currentScope = scope ++ [v]}
+
+-- | Adds a path to the "using" paths.
+addUsingPath :: [k] -> ScopePath k -> ScopePath k
+addUsingPath path s@ScopePath {usingPaths = paths} =
+  s {usingPaths = path : paths}
+
 -- | The 'Semigroup' instance for 'Scope' allows combining two scopes,
 --   where sub-scopes and values are merged together.
 instance (Ord k) => Semigroup (Scope k t) where