Add import resolution phase and also add a more abstractions around

compliation phases.

3 files changed, 180 insertions, 28 deletions

diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 90f4aa4..4c708f7 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -5,7 +5,11 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Language.Fiddle.Compiler.ConsistencyCheck (checkConsistency) where
+module Language.Fiddle.Compiler.ConsistencyCheck
+  ( checkConsistency,
+    consistencyCheckPhase,
+  )
+where
 
 import Control.Monad (forM, forM_, unless, when)
 import Control.Monad.Identity (Identity (Identity))
@@ -22,7 +26,10 @@ import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
 import qualified Data.Set as Set
 import qualified Data.Text as Text
+import Data.Void
 import Data.Word (Word32)
+import GHC.TypeError as TypeError
+import GHC.TypeLits
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler
 import Language.Fiddle.Internal.Scopes
@@ -44,6 +51,11 @@ type SizeBits = Word32
 
 type SizeBytes = Word32
 
+consistencyCheckPhase ::
+  CompilationPhase Expanded Checked
+consistencyCheckPhase =
+  CompilationPhase (const $ return ()) (\() -> checkConsistency)
+
 checkConsistency ::
   FiddleUnit Expanded I Annot ->
   Compile () (FiddleUnit Checked I Annot)
@@ -52,6 +64,13 @@ checkConsistency =
     . subCompile (GlobalState mempty)
     . advanceStage (LocalState mempty)
 
+instance CompilationStage Checked where
+  type StageAfter Checked = TypeError (TypeError.Text "No stage after Checked")
+  type StageMonad Checked = Compile GlobalState
+  type StageState Checked = LocalState
+  type StageFunctor Checked = Identity
+  type StageAnnotation Checked = Commented SourceSpan
+
 instance CompilationStage Expanded where
   type StageAfter Expanded = Checked
   type StageMonad Expanded = Compile GlobalState
@@ -81,6 +100,8 @@ deriving instance AdvanceStage Expanded EnumConstantDecl
 
 deriving instance AdvanceStage Expanded PackageBody
 
+deriving instance AdvanceStage Expanded ImportStatement
+
 deriving instance (AdvanceStage Expanded t) => AdvanceStage Expanded (Directed t)
 
 instance AdvanceStage Expanded RegisterBody where
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index 8cfd0f0..77ccf6c 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -4,7 +4,7 @@
 {-# LANGUAGE IncoherentInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Language.Fiddle.Compiler.Expansion (expandAst) where
+module Language.Fiddle.Compiler.Expansion (expandAst, expansionPhase) where
 
 import Control.Monad.Identity (Identity (..))
 import Control.Monad.State (get, gets, modify, put)
@@ -18,23 +18,29 @@ import Debug.Trace
 import GHC.TypeLits
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler
+import Language.Fiddle.Compiler.ConsistencyCheck
 import Language.Fiddle.Types
 import Text.Printf (printf)
 
+type M = Compile State
+
 type Annot = Commented SourceSpan
 
+type CurrentStage = ImportsResolved
+
 newtype Path = Path [PathExpression]
 
 newtype PathExpression = PathExpression String
 
-type M = Compile State
-
 joinPath :: Path -> String
 joinPath (Path l) = intercalate "#" $ reverse (map (\(PathExpression s) -> s) l)
 
-expandAst :: FiddleUnit Parsed I Annot -> Compile () (FiddleUnit Expanded I Annot)
+expandAst :: FiddleUnit CurrentStage I Annot -> Compile () (FiddleUnit Expanded I Annot)
 expandAst = fmap snd . subCompile (State [] []) . advanceStage (Path mempty)
 
+expansionPhase :: CompilationPhase CurrentStage Expanded
+expansionPhase = CompilationPhase (const $ return ()) (\() -> expandAst)
+
 -- Shorthand for Identity
 type I = Identity
 
@@ -47,41 +53,43 @@ data State
       -- Anonymous enum bodies that need to be re-linked
       ![(Linkage, AnonymousBitsType Expanded I Annot)]
 
-instance CompilationStage Parsed where
-  type StageAfter Parsed = Expanded
-  type StageMonad Parsed = M
-  type StageState Parsed = Path
-  type StageFunctor Parsed = Identity
-  type StageAnnotation Parsed = Annot
+instance CompilationStage CurrentStage where
+  type StageAfter CurrentStage = Expanded
+  type StageMonad CurrentStage = M
+  type StageState CurrentStage = Path
+  type StageFunctor CurrentStage = Identity
+  type StageAnnotation CurrentStage = Annot
+
+deriving instance AdvanceStage CurrentStage ObjTypeBody
 
-deriving instance AdvanceStage Parsed ObjTypeBody
+deriving instance AdvanceStage CurrentStage DeferredRegisterBody
 
-deriving instance AdvanceStage Parsed DeferredRegisterBody
+deriving instance AdvanceStage CurrentStage RegisterBody
 
-deriving instance AdvanceStage Parsed RegisterBody
+deriving instance AdvanceStage CurrentStage AnonymousBitsType
 
-deriving instance AdvanceStage Parsed AnonymousBitsType
+deriving instance AdvanceStage CurrentStage ImportStatement
 
-deriving instance AdvanceStage Parsed BitType
+deriving instance AdvanceStage CurrentStage BitType
 
-deriving instance AdvanceStage Parsed EnumBody
+deriving instance AdvanceStage CurrentStage EnumBody
 
-deriving instance AdvanceStage Parsed EnumConstantDecl
+deriving instance AdvanceStage CurrentStage EnumConstantDecl
 
-deriving instance (AdvanceStage Parsed t) => AdvanceStage Parsed (Directed t)
+deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t)
 
-instance AdvanceStage Parsed RegisterBitsDecl where
+instance AdvanceStage CurrentStage RegisterBitsDecl where
   modifyState t =
     return
       . case t of
         DefinedBits {definedBitsIdent = i} -> pushId i
         _ -> id
 
-instance AdvanceStage Parsed PackageBody where
+instance AdvanceStage CurrentStage PackageBody where
   advanceStage p (PackageBody decls a) =
     PackageBody <$> reconfigureFiddleDecls p decls <*> pure a
 
-instance AdvanceStage Parsed ObjTypeDecl where
+instance AdvanceStage CurrentStage ObjTypeDecl where
   modifyState t =
     return
       . case t of
@@ -89,7 +97,7 @@ instance AdvanceStage Parsed ObjTypeDecl where
         RegisterDecl {regIdent = (Just n)} -> pushId n
         _ -> id
 
-instance AdvanceStage Parsed FiddleDecl where
+instance AdvanceStage CurrentStage FiddleDecl where
   modifyState t =
     return
       . case t of
@@ -99,16 +107,16 @@ instance AdvanceStage Parsed FiddleDecl where
         ObjectDecl {objectIdent = i} -> pushId i
         _ -> id
 
-instance AdvanceStage Parsed FiddleUnit where
+instance AdvanceStage CurrentStage FiddleUnit where
   advanceStage path (FiddleUnit decls a) =
     FiddleUnit <$> reconfigureFiddleDecls path decls <*> pure a
 
-instance AdvanceStage Parsed Expression where
+instance AdvanceStage CurrentStage Expression where
   advanceStage _ = \case
     (Var i a) -> return $ Var i a
     (LitNum t a) -> LitNum <$> parseNum (unCommented a) t <*> pure a
 
-instance AdvanceStage Parsed RegisterBitsTypeRef where
+instance AdvanceStage CurrentStage RegisterBitsTypeRef where
   advanceStage path = \case
     RegisterBitsArray typeref expr annot ->
       RegisterBitsArray
@@ -127,7 +135,7 @@ instance AdvanceStage Parsed RegisterBitsTypeRef where
           =<< advanceStage path anonType
       return $ RegisterBitsReference (identToName ident) annot
 
-instance AdvanceStage Parsed ObjType where
+instance AdvanceStage CurrentStage ObjType where
   advanceStage path = \case
     (AnonymousObjType _ (Identity body) annot) -> do
       body' <- advanceStage path body
@@ -176,7 +184,7 @@ parseNum span txt = fromMayberOrFail span "Unable to parse number" $
 
 reconfigureFiddleDecls ::
   Path ->
-  [Directed FiddleDecl Parsed I Annot] ->
+  [Directed FiddleDecl CurrentStage I Annot] ->
   M [Directed FiddleDecl Expanded I Annot]
 reconfigureFiddleDecls p decls = do
   lastState <- get
diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs
new file mode 100644
index 0000000..b4c5293
--- /dev/null
+++ b/src/Language/Fiddle/Compiler/ImportResolution.hs
@@ -0,0 +1,123 @@
+module Language.Fiddle.Compiler.ImportResolution
+  ( resolveImports,
+    getImportResolutionState,
+    ImportResolutionOptions (..),
+    importResolutionPhase,
+  )
+where
+
+import Control.Monad.Identity (Identity)
+import Control.Monad.Writer.Lazy (MonadWriter (tell))
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Language.Fiddle.Ast
+import Language.Fiddle.Ast.FileInterface (ResolvedImport)
+import Language.Fiddle.Compiler
+import Language.Fiddle.Compiler.Expansion
+import Language.Fiddle.Internal.UnitInterface
+import Language.Fiddle.Types
+import Text.Printf (printf)
+
+type GlobalState = ()
+
+type LocalState = ResolvedImports
+
+type M = Compile GlobalState
+
+type Annot = Commented SourceSpan
+
+data ImportError = ImportError Text (Maybe SourceSpan)
+  deriving (Show)
+
+newtype ResolvedImports = ResolvedImports
+  { importMap :: Map Text (Either ImportError UnitInterface)
+  }
+
+type CurrentStage = Parsed
+
+type I = Identity
+
+instance CompilationStage CurrentStage where
+  type StageAfter CurrentStage = ImportsResolved
+  type StageMonad CurrentStage = M
+  type StageState CurrentStage = LocalState
+  type StageFunctor CurrentStage = Identity
+  type StageAnnotation CurrentStage = Annot
+
+importResolutionPhase ::
+  ImportResolutionOptions ->
+  CompilationPhase CurrentStage ImportsResolved
+importResolutionPhase opts =
+  CompilationPhase
+    (getImportResolutionState opts)
+    resolveImports
+
+resolveImports ::
+  ResolvedImports ->
+  FiddleUnit CurrentStage I Annot ->
+  Compile () (FiddleUnit ImportsResolved I Annot)
+resolveImports = advanceStage
+
+deriving instance AdvanceStage CurrentStage ObjTypeBody
+
+deriving instance AdvanceStage CurrentStage DeferredRegisterBody
+
+deriving instance AdvanceStage CurrentStage RegisterBody
+
+deriving instance AdvanceStage CurrentStage AnonymousBitsType
+
+deriving instance AdvanceStage CurrentStage BitType
+
+deriving instance AdvanceStage CurrentStage EnumBody
+
+deriving instance AdvanceStage CurrentStage EnumConstantDecl
+
+deriving instance AdvanceStage CurrentStage RegisterBitsDecl
+
+deriving instance AdvanceStage CurrentStage PackageBody
+
+deriving instance AdvanceStage CurrentStage ObjTypeDecl
+
+deriving instance AdvanceStage CurrentStage FiddleUnit
+
+deriving instance AdvanceStage CurrentStage Expression
+
+deriving instance AdvanceStage CurrentStage RegisterBitsTypeRef
+
+deriving instance AdvanceStage CurrentStage ObjType
+
+deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t)
+
+deriving instance AdvanceStage CurrentStage FiddleDecl
+
+diagnosticError :: String -> Annot -> Compile a ()
+diagnosticError str a = tell [Diagnostic Error str (unCommented a)]
+
+instance AdvanceStage CurrentStage ImportStatement where
+  advanceStage s (ImportStatement path list _ a) = do
+    let what = Map.lookup path (importMap s)
+        empty = UnitInterface mempty mempty
+
+    v <- case what of
+      Nothing -> do
+        diagnosticError "Failed to lookup imports (This is a bug)" a
+        return empty
+      Just (Left err) -> do
+        diagnosticError (printf "Error in import %s: %s" path (show err)) a
+        return empty
+      Just (Right val) -> return val
+
+    return $ ImportStatement path list v a
+
+newtype ImportResolutionOptions
+  = ImportResolutionOptions
+  { searchPath :: [FilePath]
+  }
+
+getImportResolutionState ::
+  ImportResolutionOptions ->
+  FiddleUnit CurrentStage Identity Annot ->
+  IO ResolvedImports
+getImportResolutionState _ _ = return (ResolvedImports mempty)