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/Stage1.hs15
-rw-r--r--src/Language/Fiddle/Compiler/Stage2.hs39
2 files changed, 30 insertions, 24 deletions
diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs
index 25ee66b..2e3acbc 100644
--- a/src/Language/Fiddle/Compiler/Stage1.hs
+++ b/src/Language/Fiddle/Compiler/Stage1.hs
@@ -68,7 +68,7 @@ toStage2 (FiddleUnit decls annot) = do
FiddleUnit <$> reconfigureFiddleDecls (Path []) decls <*> pure annot
return a
-reconfigureFiddleDecls :: Path -> [FiddleDecl Stage1 I Annot] -> M Annot [FiddleDecl Stage2 I Annot]
+reconfigureFiddleDecls :: Path -> [Directed (FiddleDecl Stage1) I Annot] -> M Annot [Directed (FiddleDecl Stage2) I Annot]
reconfigureFiddleDecls p decls = do
-- (Stage2CompilerState anonymousObjTypes anonymousBitsTypes, decls) <- pushState $ do
-- put (Stage2CompilerState [] [])
@@ -76,13 +76,13 @@ reconfigureFiddleDecls p decls = do
lastState <- get
put (Stage2CompilerState [] [])
- decls <- mapM (fiddleDeclToStage2 p) decls
+ decls <- mapM (mapDirectedM $ fiddleDeclToStage2 p) decls
(Stage2CompilerState anonymousObjTypes anonymousBitsTypes) <- get
put lastState
return $
- map resolveAnonymousObjType anonymousObjTypes
- ++ map resolveAnonymousBitsType anonymousBitsTypes
+ map (asDirected . resolveAnonymousObjType) anonymousObjTypes
+ ++ map (asDirected . resolveAnonymousBitsType) anonymousBitsTypes
++ decls
where
resolveAnonymousObjType (Linkage linkage, objTypeBody) =
@@ -104,6 +104,7 @@ fiddleDeclToStage2 path decl = do
(LocationDecl i expr a) -> LocationDecl i <$> toStage2Expr expr <*> pure a
(BitsDecl i typ a) -> BitsDecl i <$> bitsTypeToStage2 (pushId i path) typ <*> pure a
(ObjTypeDecl i body a) -> ObjTypeDecl i <$> mapM (objTypeBodyToStage2 (pushId i path)) body <*> pure a
+ (ImportDecl importStatement a) -> return $ ImportDecl importStatement a
(ObjectDecl i expr typ a) ->
ObjectDecl i <$> toStage2Expr expr <*> objectTypeToStage2 (pushId i path) typ <*> pure a
@@ -115,7 +116,7 @@ bitsTypeToStage2 path = \case
enumBodyToStage2 :: Path -> EnumBody Stage1 I Annot -> M Annot (EnumBody Stage2 I Annot)
enumBodyToStage2 path = \case
- EnumBody constants a -> EnumBody <$> mapM (enumConstantToStage2 path) constants <*> pure a
+ EnumBody constants a -> EnumBody <$> mapM (mapDirectedM (enumConstantToStage2 path)) constants <*> pure a
enumConstantToStage2 :: Path -> EnumConstantDecl Stage1 I Annot -> M Annot (EnumConstantDecl Stage2 I Annot)
enumConstantToStage2 path = \case
@@ -124,7 +125,7 @@ enumConstantToStage2 path = \case
objTypeBodyToStage2 :: Path -> ObjTypeBody Stage1 I Annot -> M Annot (ObjTypeBody Stage2 I Annot)
objTypeBodyToStage2 path (ObjTypeBody bodyType decls annot) =
- ObjTypeBody bodyType <$> mapM (objTypeDeclToStage2 path) decls <*> pure annot
+ ObjTypeBody bodyType <$> mapM (mapDirectedM $ objTypeDeclToStage2 path) decls <*> pure annot
objTypeDeclToStage2 :: Path -> ObjTypeDecl Stage1 I Annot -> M Annot (ObjTypeDecl Stage2 I Annot)
objTypeDeclToStage2 path = \case
@@ -150,7 +151,7 @@ registerBodyToStage2 :: Path -> RegisterBody Stage1 I Annot -> M Annot (Register
registerBodyToStage2 path (RegisterBody bodyType (Identity (DeferredRegisterBody registerBitsDecl a1)) a2) =
RegisterBody bodyType . Identity
<$> ( DeferredRegisterBody
- <$> mapM (registerBitsDeclToStage2 path) registerBitsDecl
+ <$> mapM (mapDirectedM $ registerBitsDeclToStage2 path) registerBitsDecl
<*> pure a1
)
<*> pure a2
diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/Stage2.hs
index 727f153..431fc76 100644
--- a/src/Language/Fiddle/Compiler/Stage2.hs
+++ b/src/Language/Fiddle/Compiler/Stage2.hs
@@ -72,7 +72,7 @@ toStage3 (FiddleUnit decls a) =
snd
<$> subCompile
emptyState
- ( FiddleUnit <$> mapM fiddleDeclToStage3 decls <*> pure a
+ ( FiddleUnit <$> mapM (mapDirectedM fiddleDeclToStage3) decls <*> pure a
)
exprToSize ::
@@ -94,7 +94,7 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do
when (declaredSize <= 4) $ do
imap <-
foldlM
- ( \imap enumConst -> do
+ ( \imap (undirected -> enumConst) -> do
number <- case enumConst of
EnumConstantDecl _ expr _ -> exprToSize expr
EnumConstantReserved expr _ -> exprToSize expr
@@ -137,6 +137,7 @@ fiddleDeclToStage3 = \case
BitsDecl id <$> bitTypeToStage3 typ <*> pure a
ObjTypeDecl ident body a ->
ObjTypeDecl ident <$> mapM (\bt -> fst <$> objTypeBodyToStage3 bt 0) body <*> pure a
+ ImportDecl importStatement a -> return $ ImportDecl importStatement a
ObjectDecl ident expr typ a ->
ObjectDecl ident (expressionToStage3 expr) <$> objTypeToStage3 typ <*> pure a
@@ -162,10 +163,10 @@ registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a')
(cur, returned) <-
foldlM
( \(cursor, returned) decl ->
- case decl of
+ case undirected decl of
ReservedBits expr a -> do
size <- fromIntegral <$> exprToSize expr
- let s3 = ReservedBits (expressionToStage3 expr) a
+ let s3 = mapDirected (const $ ReservedBits (expressionToStage3 expr) a) decl
if isUnion
then checkUnion cursor size (s3 : returned) a
else
@@ -174,7 +175,7 @@ registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a')
checkBitsSubStructure registerBody maybeIdent annot
(newBody, subsize) <- registerBodyToStage3 registerBody
- let s3 = BitsSubStructure newBody maybeIdent annot
+ let s3 = mapDirected (const $ BitsSubStructure newBody maybeIdent annot) decl
if isUnion
then checkUnion cursor subsize (s3 : returned) a
@@ -182,7 +183,7 @@ registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a')
return (cursor + subsize, s3 : returned)
DefinedBits modifier identifier typeref a -> do
(s3TypeRef, size) <- registerBitsTypeRefToStage3 typeref
- let s3 = DefinedBits modifier identifier s3TypeRef a
+ let s3 = mapDirected (const $ DefinedBits modifier identifier s3TypeRef a) decl
if isUnion
then checkUnion cursor size (s3 : returned) a
@@ -265,18 +266,22 @@ objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do
(cur, returned) <-
foldlM
( \(cursor, returned) decl ->
- case decl of
+ case undirected decl of
RegisterDecl mMod mIdent expr mBody a -> do
(s3RegisterBody, mCalculatedSize) <-
fUnzip <$> mapM registerBodyToStage3 mBody
let s3 =
- RegisterDecl
- mMod
- mIdent
- (expressionToStage3 expr)
- s3RegisterBody
- a
+ mapDirected
+ ( const $
+ RegisterDecl
+ mMod
+ mIdent
+ (expressionToStage3 expr)
+ s3RegisterBody
+ a
+ )
+ decl
declaredSizeBits <- fromIntegral <$> exprToSize expr
@@ -320,7 +325,7 @@ objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do
subBody
( if isUnion then startOff else cursor
)
- let s3 = TypeSubStructure (Identity newBody) maybeIdent annot
+ let s3 = mapDirected (const $ TypeSubStructure (Identity newBody) maybeIdent annot) decl
checkTypesSubStructure subBody maybeIdent annot
if isUnion
@@ -338,7 +343,7 @@ objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do
(unCommented a)
]
let size = size' `div` 8
- let s3 = ReservedDecl (expressionToStage3 expr) annot
+ let s3 = mapDirected (const $ ReservedDecl (expressionToStage3 expr) annot) decl
if isUnion
then
checkUnion cursor size (s3 : returned) a
@@ -406,7 +411,7 @@ bitTypeToStage3 (EnumBitType expr body a) =
enumBodyToStage3 :: EnumBody Stage2 I Annot -> Compile Stage3State (EnumBody Stage3 I Annot)
enumBodyToStage3 (EnumBody constants a) =
- EnumBody <$> mapM enumConstantDeclToStage3 constants <*> pure a
+ EnumBody <$> mapM (mapDirectedM enumConstantDeclToStage3) constants <*> pure a
enumConstantDeclToStage3 :: EnumConstantDecl Stage2 I Annot -> Compile Stage3State (EnumConstantDecl Stage3 I Annot)
enumConstantDeclToStage3 = \case
@@ -415,4 +420,4 @@ enumConstantDeclToStage3 = \case
packageBodyToStage3 :: PackageBody Stage2 I Annot -> Compile Stage3State (PackageBody Stage3 I Annot)
packageBodyToStage3 (PackageBody decls a) =
- PackageBody <$> mapM fiddleDeclToStage3 decls <*> pure a
+ PackageBody <$> mapM (mapDirectedM fiddleDeclToStage3) decls <*> pure a
generated by cgit (git 2.34.1) at 2025-07-07 01:03:28 +0000