Add import resolution phase and also add a more abstractions around

compliation phases.

1 files changed, 123 insertions, 0 deletions

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)