summaryrefslogtreecommitdiff
path: root/src/Language/Fiddle/Compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/Fiddle/Compiler')
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs23
-rw-r--r--src/Language/Fiddle/Compiler/Expansion.hs62
-rw-r--r--src/Language/Fiddle/Compiler/ImportResolution.hs123
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)
generated by cgit (git 2.34.1) at 2025-07-07 12:11:15 +0000