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.hs (renamed from src/Language/Fiddle/Compiler/Stage2.hs)73
-rw-r--r--src/Language/Fiddle/Compiler/Expansion.hs (renamed from src/Language/Fiddle/Compiler/Stage1.hs)62
-rw-r--r--src/Language/Fiddle/Compiler/Stage0.hs8
3 files changed, 76 insertions, 67 deletions
diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index adf5450..90f4aa4 100644
--- a/src/Language/Fiddle/Compiler/Stage2.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -5,7 +5,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-module Language.Fiddle.Compiler.Stage2 (toStage3) where
+module Language.Fiddle.Compiler.ConsistencyCheck (checkConsistency) where
import Control.Monad (forM, forM_, unless, when)
import Control.Monad.Identity (Identity (Identity))
@@ -44,47 +44,52 @@ type SizeBits = Word32
type SizeBytes = Word32
-toStage3 :: FiddleUnit Stage2 I Annot -> Compile () (FiddleUnit Stage3 I Annot)
-toStage3 = fmap snd . subCompile (GlobalState mempty) . advanceStage (LocalState mempty)
+checkConsistency ::
+ FiddleUnit Expanded I Annot ->
+ Compile () (FiddleUnit Checked I Annot)
+checkConsistency =
+ fmap snd
+ . subCompile (GlobalState mempty)
+ . advanceStage (LocalState mempty)
-instance CompilationStage Stage2 where
- type StageAfter Stage2 = Stage3
- type StageMonad Stage2 = Compile GlobalState
- type StageState Stage2 = LocalState
- type StageFunctor Stage2 = Identity
- type StageAnnotation Stage2 = Commented SourceSpan
+instance CompilationStage Expanded where
+ type StageAfter Expanded = Checked
+ type StageMonad Expanded = Compile GlobalState
+ type StageState Expanded = LocalState
+ type StageFunctor Expanded = Identity
+ type StageAnnotation Expanded = Commented SourceSpan
-deriving instance AdvanceStage Stage2 FiddleUnit
+deriving instance AdvanceStage Expanded FiddleUnit
-deriving instance AdvanceStage Stage2 Expression
+deriving instance AdvanceStage Expanded Expression
-deriving instance AdvanceStage Stage2 ObjType
+deriving instance AdvanceStage Expanded ObjType
-deriving instance AdvanceStage Stage2 DeferredRegisterBody
+deriving instance AdvanceStage Expanded DeferredRegisterBody
-deriving instance AdvanceStage Stage2 RegisterBitsDecl
+deriving instance AdvanceStage Expanded RegisterBitsDecl
-deriving instance AdvanceStage Stage2 RegisterBitsTypeRef
+deriving instance AdvanceStage Expanded RegisterBitsTypeRef
-deriving instance AdvanceStage Stage2 AnonymousBitsType
+deriving instance AdvanceStage Expanded AnonymousBitsType
-deriving instance AdvanceStage Stage2 BitType
+deriving instance AdvanceStage Expanded BitType
-deriving instance AdvanceStage Stage2 EnumBody
+deriving instance AdvanceStage Expanded EnumBody
-deriving instance AdvanceStage Stage2 EnumConstantDecl
+deriving instance AdvanceStage Expanded EnumConstantDecl
-deriving instance AdvanceStage Stage2 PackageBody
+deriving instance AdvanceStage Expanded PackageBody
-deriving instance (AdvanceStage Stage2 t) => AdvanceStage Stage2 (Directed t)
+deriving instance (AdvanceStage Expanded t) => AdvanceStage Expanded (Directed t)
-instance AdvanceStage Stage2 RegisterBody where
+instance AdvanceStage Expanded RegisterBody where
advanceStage s body = fst <$> registerBodyToStage3 s body
-instance AdvanceStage Stage2 ObjTypeBody where
+instance AdvanceStage Expanded ObjTypeBody where
advanceStage s body = fst <$> objTypeBodyToStage3 s body 0
-instance AdvanceStage Stage2 FiddleDecl where
+instance AdvanceStage Expanded FiddleDecl where
modifyState t s = case t of
(BitsDecl id typ a) -> do
typeSize <- getTypeSize typ
@@ -111,9 +116,9 @@ nameToList (Name idents _) = map (\(Identifier (Text.unpack -> s) _) -> s) (toLi
objTypeBodyToStage3 ::
LocalState ->
- ObjTypeBody Stage2 I Annot ->
+ ObjTypeBody Expanded I Annot ->
Word32 ->
- Compile GlobalState (ObjTypeBody Stage3 I Annot, Word32)
+ Compile GlobalState (ObjTypeBody Checked I Annot, Word32)
objTypeBodyToStage3 st (ObjTypeBody bodyType decls a) startOff = do
let isUnion = case bodyType of
Union {} -> True
@@ -265,8 +270,8 @@ objTypeBodyToStage3 st (ObjTypeBody bodyType decls a) startOff = do
registerBodyToStage3 ::
LocalState ->
- RegisterBody Stage2 I Annot ->
- Compile GlobalState (RegisterBody Stage3 I Annot, Word32)
+ RegisterBody Expanded I Annot ->
+ Compile GlobalState (RegisterBody Checked I Annot, Word32)
registerBodyToStage3
st
(RegisterBody bodyType (Identity deferredRegisterBody) a') = do
@@ -356,8 +361,8 @@ registerBodyToStage3
registerBitsTypeRefToStage3 ::
LocalState ->
- RegisterBitsTypeRef Stage2 I Annot ->
- Compile GlobalState (RegisterBitsTypeRef Stage3 I Annot, Word32)
+ RegisterBitsTypeRef Expanded I Annot ->
+ Compile GlobalState (RegisterBitsTypeRef Checked I Annot, Word32)
registerBitsTypeRefToStage3 localState = \case
RegisterBitsArray ref expr a -> do
(ref', size) <- registerBitsTypeRefToStage3 localState ref
@@ -446,7 +451,7 @@ lookupTypeSize (LocalState scopePath) (Name idents a) = do
]
compilationFailure
-getTypeSize :: BitType Stage2 I Annot -> Compile s SizeBits
+getTypeSize :: BitType Expanded I Annot -> Compile s SizeBits
getTypeSize (RawBits expr _) = fromIntegral <$> exprToSize expr
getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do
declaredSize <- fromIntegral <$> exprToSize expr
@@ -495,7 +500,11 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do
diagnosticError :: String -> Annot -> Compile a ()
diagnosticError str a = tell [Diagnostic Error str (unCommented a)]
-insertTypeSize :: LocalState -> Identifier f Annot -> SizeBits -> Compile GlobalState ()
+insertTypeSize ::
+ LocalState ->
+ Identifier f Annot ->
+ SizeBits ->
+ Compile GlobalState ()
insertTypeSize (LocalState scopePath) (Identifier s annot) size = do
modifyM $
\(GlobalState globalScope) ->
diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index aae80e4..8cfd0f0 100644
--- a/src/Language/Fiddle/Compiler/Stage1.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -4,7 +4,7 @@
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE UndecidableInstances #-}
-module Language.Fiddle.Compiler.Stage1 (toStage2) where
+module Language.Fiddle.Compiler.Expansion (expandAst) where
import Control.Monad.Identity (Identity (..))
import Control.Monad.State (get, gets, modify, put)
@@ -32,8 +32,8 @@ type M = Compile State
joinPath :: Path -> String
joinPath (Path l) = intercalate "#" $ reverse (map (\(PathExpression s) -> s) l)
-toStage2 :: FiddleUnit Stage1 I Annot -> Compile () (FiddleUnit Stage2 I Annot)
-toStage2 = fmap snd . subCompile (State [] []) . advanceStage (Path mempty)
+expandAst :: FiddleUnit Parsed I Annot -> Compile () (FiddleUnit Expanded I Annot)
+expandAst = fmap snd . subCompile (State [] []) . advanceStage (Path mempty)
-- Shorthand for Identity
type I = Identity
@@ -43,45 +43,45 @@ newtype Linkage = Linkage Text deriving (Show)
data State
= State
-- Anonymous object type bodies that need to be re-linked
- ![(Linkage, ObjTypeBody Stage2 I Annot)]
+ ![(Linkage, ObjTypeBody Expanded I Annot)]
-- Anonymous enum bodies that need to be re-linked
- ![(Linkage, AnonymousBitsType Stage2 I Annot)]
+ ![(Linkage, AnonymousBitsType Expanded I Annot)]
-instance CompilationStage Stage1 where
- type StageAfter Stage1 = Stage2
- type StageMonad Stage1 = M
- type StageState Stage1 = Path
- type StageFunctor Stage1 = Identity
- type StageAnnotation Stage1 = 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
-deriving instance AdvanceStage Stage1 ObjTypeBody
+deriving instance AdvanceStage Parsed ObjTypeBody
-deriving instance AdvanceStage Stage1 DeferredRegisterBody
+deriving instance AdvanceStage Parsed DeferredRegisterBody
-deriving instance AdvanceStage Stage1 RegisterBody
+deriving instance AdvanceStage Parsed RegisterBody
-deriving instance AdvanceStage Stage1 AnonymousBitsType
+deriving instance AdvanceStage Parsed AnonymousBitsType
-deriving instance AdvanceStage Stage1 BitType
+deriving instance AdvanceStage Parsed BitType
-deriving instance AdvanceStage Stage1 EnumBody
+deriving instance AdvanceStage Parsed EnumBody
-deriving instance AdvanceStage Stage1 EnumConstantDecl
+deriving instance AdvanceStage Parsed EnumConstantDecl
-deriving instance (AdvanceStage Stage1 t) => AdvanceStage Stage1 (Directed t)
+deriving instance (AdvanceStage Parsed t) => AdvanceStage Parsed (Directed t)
-instance AdvanceStage Stage1 RegisterBitsDecl where
+instance AdvanceStage Parsed RegisterBitsDecl where
modifyState t =
return
. case t of
DefinedBits {definedBitsIdent = i} -> pushId i
_ -> id
-instance AdvanceStage Stage1 PackageBody where
+instance AdvanceStage Parsed PackageBody where
advanceStage p (PackageBody decls a) =
PackageBody <$> reconfigureFiddleDecls p decls <*> pure a
-instance AdvanceStage Stage1 ObjTypeDecl where
+instance AdvanceStage Parsed ObjTypeDecl where
modifyState t =
return
. case t of
@@ -89,7 +89,7 @@ instance AdvanceStage Stage1 ObjTypeDecl where
RegisterDecl {regIdent = (Just n)} -> pushId n
_ -> id
-instance AdvanceStage Stage1 FiddleDecl where
+instance AdvanceStage Parsed FiddleDecl where
modifyState t =
return
. case t of
@@ -99,16 +99,16 @@ instance AdvanceStage Stage1 FiddleDecl where
ObjectDecl {objectIdent = i} -> pushId i
_ -> id
-instance AdvanceStage Stage1 FiddleUnit where
+instance AdvanceStage Parsed FiddleUnit where
advanceStage path (FiddleUnit decls a) =
FiddleUnit <$> reconfigureFiddleDecls path decls <*> pure a
-instance AdvanceStage Stage1 Expression where
+instance AdvanceStage Parsed Expression where
advanceStage _ = \case
(Var i a) -> return $ Var i a
(LitNum t a) -> LitNum <$> parseNum (unCommented a) t <*> pure a
-instance AdvanceStage Stage1 RegisterBitsTypeRef where
+instance AdvanceStage Parsed RegisterBitsTypeRef where
advanceStage path = \case
RegisterBitsArray typeref expr annot ->
RegisterBitsArray
@@ -127,7 +127,7 @@ instance AdvanceStage Stage1 RegisterBitsTypeRef where
=<< advanceStage path anonType
return $ RegisterBitsReference (identToName ident) annot
-instance AdvanceStage Stage1 ObjType where
+instance AdvanceStage Parsed ObjType where
advanceStage path = \case
(AnonymousObjType _ (Identity body) annot) -> do
body' <- advanceStage path body
@@ -176,8 +176,8 @@ parseNum span txt = fromMayberOrFail span "Unable to parse number" $
reconfigureFiddleDecls ::
Path ->
- [Directed FiddleDecl Stage1 I Annot] ->
- M [Directed FiddleDecl Stage2 I Annot]
+ [Directed FiddleDecl Parsed I Annot] ->
+ M [Directed FiddleDecl Expanded I Annot]
reconfigureFiddleDecls p decls = do
lastState <- get
put (State [] [])
@@ -202,7 +202,7 @@ reconfigureFiddleDecls p decls = do
identToName :: Identifier I a -> Name I a
identToName ident = Name (NonEmpty.singleton ident) (annot ident)
-internObjType :: Path -> ObjTypeBody Stage2 I Annot -> M (Identifier I Annot)
+internObjType :: Path -> ObjTypeBody Expanded I Annot -> M (Identifier I Annot)
internObjType path body =
let str = Text.pack $ joinPath path
in do
@@ -212,7 +212,7 @@ internObjType path body =
internAnonymousBitsType ::
Path ->
- AnonymousBitsType Stage2 I Annot ->
+ AnonymousBitsType Expanded I Annot ->
M (Identifier I Annot)
internAnonymousBitsType path anonymousBitsType =
let str = Text.pack $ joinPath path
diff --git a/src/Language/Fiddle/Compiler/Stage0.hs b/src/Language/Fiddle/Compiler/Stage0.hs
index fbc554b..96ee539 100644
--- a/src/Language/Fiddle/Compiler/Stage0.hs
+++ b/src/Language/Fiddle/Compiler/Stage0.hs
@@ -15,7 +15,7 @@ newtype Stage0Diagnostic = SyntaxError String
toStage0 ::
String ->
Data.Text.Text ->
- Compile () (FiddleUnit Stage1 (Either ParseError) (Commented SourceSpan))
+ Compile () (FiddleUnit Parsed (Either ParseError) (Commented SourceSpan))
toStage0 filePath text =
case Language.Fiddle.Parser.parseFiddleText filePath text of
Left pe -> do
@@ -23,13 +23,13 @@ toStage0 filePath text =
compilationFailure
Right a -> return a
--- Gets the AST ready for Stage1 processing .This will report primarily
+-- Gets the AST ready for Parsed processing .This will report primarily
-- SyntaxErrors and errors parsing the tree.
--
-- In the process, the tree is un-deferred and all parts of the
toStage1 ::
- FiddleUnit Stage1 (Either ParseError) a ->
- Compile () (FiddleUnit Stage1 Identity a)
+ FiddleUnit Parsed (Either ParseError) a ->
+ Compile () (FiddleUnit Parsed Identity a)
toStage1 ast = do
alter
( \case
generated by cgit (git 2.34.1) at 2025-07-12 23:33:55 +0000