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/Backend.hs7
-rw-r--r--src/Language/Fiddle/Compiler/Backend/C.hs423
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs21
-rw-r--r--src/Language/Fiddle/Compiler/Qualification.hs116
4 files changed, 445 insertions, 122 deletions
diff --git a/src/Language/Fiddle/Compiler/Backend.hs b/src/Language/Fiddle/Compiler/Backend.hs
index ddb32c6..eda3ede 100644
--- a/src/Language/Fiddle/Compiler/Backend.hs
+++ b/src/Language/Fiddle/Compiler/Backend.hs
@@ -25,13 +25,6 @@ instance Semigroup TranspileResult where
instance Monoid TranspileResult where
mempty = TranspileResult mempty
--- | "Opens" a file in the broader context of a TransplieResult, and writes the
--- resulting bytestring to it
-withFile ::
- (MonadWriter TranspileResult m) => FilePath -> Writer Text () -> m ()
-withFile path bsWriter =
- tell (TranspileResult $ Map.singleton path $ execWriter bsWriter)
-
-- | A backend for the FiddleCompiler. Takes a Checked FiddleUnit and emits
-- generated code for that fiddle unit.
data Backend where
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index 645fa85..9dbbec6 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -1,27 +1,36 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
module Language.Fiddle.Compiler.Backend.C (cBackend) where
-import Control.Arrow (Arrow (second))
+import Control.Arrow
+import Control.Monad (unless)
import Control.Monad.RWS
+import Control.Monad.State (State)
+import Control.Monad.Trans.Writer (Writer, execWriter)
import Data.Char (isSpace)
import Data.Data (Typeable, cast)
import Data.Foldable (forM_, toList)
import Data.Kind (Type)
+import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Set (Set)
+import qualified Data.Set as Set
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as Text
import Language.Fiddle.Ast
import Language.Fiddle.Compiler.Backend
import Language.Fiddle.Internal.UnitInterface
+import Language.Fiddle.Internal.UnitNumbers
import Language.Fiddle.Types
import Options.Applicative
+import Text.Printf (printf)
data ImplementationInHeader = ImplementationInHeader
@@ -30,17 +39,31 @@ data CBackendFlags = CBackendFlags
cHeaderOut :: FilePath
}
-newtype FilePosition = FilePosition Int
+type StructName = Text
+
+newtype Fragment = Fragment Int
deriving (Eq, Ord)
-headerPos :: FilePosition
-headerPos = FilePosition 0
+-- | Header fragment. The top. Starts which include guards and has include
+-- statements.
+hF :: Fragment
+hF = Fragment 0
+
+-- | Structures fragment. The text fragment where structures are defined.
+sF :: Fragment
+sF = Fragment 25
+
+-- | Implementation fragment. This is where function implementations go.
+iF :: Fragment
+iF = Fragment 75
-middlePos :: FilePosition
-middlePos = FilePosition 50
+-- | Assert fragment. This is where static asserts go.
+aF :: Fragment
+aF = Fragment 50
-footerPos :: FilePosition
-footerPos = FilePosition 100
+-- | Footer fragment. This is wehre the file include endif goes.
+fF :: Fragment
+fF = Fragment 100
tellLn :: (MonadWriter Text m) => Text -> m ()
tellLn s = tell s >> tell "\n"
@@ -49,8 +72,10 @@ type A = Commented SourceSpan
type I = Identity
--- | Current local state information while traversing the tree.
data St = St
+
+-- | Current local state information while traversing the tree.
+data Fmt = Fmt
{ indentLevel :: Int,
pendingLine :: Text
}
@@ -58,16 +83,16 @@ data St = St
newtype M a = M {unM :: RWS () () (St, Files) a}
deriving newtype (Functor, Applicative, Monad, MonadState (St, Files))
-newtype FormattedWriter a = FormattedWriter (RWS () Text St a)
- deriving newtype (Functor, Applicative, Monad, MonadState St)
+newtype FormattedWriter a = FormattedWriter (RWS () Text Fmt a)
+ deriving newtype (Functor, Applicative, Monad, MonadState Fmt)
-indented :: FormattedWriter a -> FormattedWriter a
+indented :: FileM a -> FileM a
indented fn = do
- modify (\(St id p) -> St (id + 1) p)
- fn <* modify (\(St id p) -> St (id - 1) p)
+ textM (modify (\(Fmt id p) -> Fmt (id + 1) p))
+ fn <* textM (modify (\(Fmt id p) -> Fmt (id - 1) p))
execFormattedWriter :: FormattedWriter a -> Text
-execFormattedWriter ((>> flush) -> FormattedWriter rws) = snd $ execRWS rws () (St 0 "")
+execFormattedWriter ((>> flush) -> FormattedWriter rws) = snd $ execRWS rws () (Fmt 0 "")
flush :: FormattedWriter ()
flush = do
@@ -75,23 +100,68 @@ flush = do
modify $ \s -> s {pendingLine = ""}
tell p
-data Files = Files
- { filepaths :: Map FilePath (Map FilePosition (FormattedWriter ()))
+newtype FileFragments = FileFragments (Map Fragment (FormattedWriter ()))
+
+instance Semigroup FileFragments where
+ (FileFragments m1) <> (FileFragments m2) = FileFragments (Map.unionWith (>>) m1 m2)
+
+instance Monoid FileFragments where
+ mempty = FileFragments mempty
+
+newtype CFileState = CFileState
+ { includedFiles :: Set String
}
-withFileAt :: FilePath -> FilePosition -> FormattedWriter () -> M ()
-withFileAt fp pos wr = do
+newtype FileM a = FileM {unFileM :: RWS Fragment FileFragments CFileState a}
+ deriving newtype (Functor, Applicative, Monad, MonadWriter FileFragments, MonadReader Fragment, MonadState CFileState)
+
+execFileM :: FileM a -> Text
+execFileM fm =
+ let (_, FileFragments mp) = execRWS (unFileM fm) hF (CFileState mempty)
+ in ( execFormattedWriter
+ . sequence_
+ . Map.elems
+ )
+ mp
+
+requireInclude :: String -> FileM ()
+requireInclude file = do
+ b <- (Set.member file) <$> gets includedFiles
+ unless b $ do
+ under hF $
+ text $
+ Text.pack $
+ printf "#include <%s>\n" file
+ modify $ \s -> s {includedFiles = Set.insert file (includedFiles s)}
+
+-- | Writes text to the current fragment context
+text :: Text -> FileM ()
+text t = flip tellF_ t =<< ask
+
+-- | Writes text to the current fragment context
+textM :: FormattedWriter () -> FileM ()
+textM t = flip tellFM_ t =<< ask
+
+-- | Executes a file monad within a different fragment.
+under :: Fragment -> FileM () -> FileM ()
+under fr = local (const fr)
+
+tellF_ :: Fragment -> Text -> FileM ()
+tellF_ fp txt = tell $ FileFragments $ Map.singleton fp (tell txt)
+
+tellFM_ :: Fragment -> FormattedWriter () -> FileM ()
+tellFM_ fp txtM = tell $ FileFragments $ Map.singleton fp txtM
+
+newtype Files = Files
+ { filepaths :: Map FilePath (FileM ())
+ }
+
+withFile :: FilePath -> FileM () -> M ()
+withFile fp fn = do
modify
( second $ \(Files {filepaths = fps}) ->
Files
- { filepaths =
- Map.alter
- ( \(fromMaybe mempty -> posMap) ->
- Just $
- Map.alter (Just . (>> wr) . fromMaybe (return ())) pos posMap
- )
- fp
- fps
+ { filepaths = Map.alter (Just . (>> fn) . fromMaybe (return ())) fp fps
}
)
@@ -106,7 +176,7 @@ instance MonadWriter Text FormattedWriter where
tell pending
tell line
tell "\n"
- modify $ \s -> s {pendingLine = last lines}
+ modify $ \s -> s {pendingLine = pendingLine s <> last lines}
listen (FormattedWriter fn) = FormattedWriter $ listen fn
@@ -143,13 +213,7 @@ cBackend =
toTranspileResult :: Files -> TranspileResult
toTranspileResult Files {filepaths = fps} =
- TranspileResult $
- fmap
- ( execFormattedWriter
- . sequence_
- . Map.elems
- )
- fps
+ TranspileResult $ fmap execFileM fps
transpile ::
CBackendFlags ->
@@ -162,21 +226,28 @@ transpile
cSourceOut = sourceFile
}
()
- fiddleUnit = toTranspileResult . snd . fst $ execRWS (unM run) () (St 0 "", Files mempty)
+ fiddleUnit = toTranspileResult . snd . fst $ execRWS (unM run) () (St, Files mempty)
where
run :: M ()
run = do
- withFileAt headerFile headerPos $ do
- tell $ "#ifndef " <> headerGuard <> "\n"
- tell $ "#define " <> headerGuard <> "\n"
+ withFile headerFile $ do
+ textM $ do
+ tell $ "#ifndef " <> headerGuard <> "\n"
+ tell $ "#define " <> headerGuard <> "\n\n"
+ tell "#include <stdint.h>\n"
+
+ -- Pad out the implementation
+ under iF $ text "\n"
walk (transpileWalk sourceFile headerFile) fiddleUnit ()
- withFileAt headerFile footerPos $ tell headerFinal
- withFileAt headerFile headerPos $ do
- tell "\n#include <stdint.h>\n"
+ withFile headerFile $ do
+ under hF $
+ textM $ do
+ tell "\nstatic_assert(true); // https://github.com/clangd/clangd/issues/1167\n"
- tell "\nstatic_assert(true); // https://github.com/clangd/clangd/issues/1167\n"
+ under fF $
+ text headerFinal
headerFinal = "\n#endif /* " <> headerGuard <> " */\n"
@@ -208,43 +279,210 @@ ensureNL = do
tell p
tell "\n"
-pad :: (IsString t, MonadWriter t m) => m a -> m a
-pad f = tell "\n" *> f <* tell "\n"
+pad :: FileM () -> FileM ()
+pad f = text "\n" *> f <* text "\n"
+
+writeStaticAssert :: Text -> String -> N Bytes -> FileM ()
+writeStaticAssert structName regname off = do
+ requireInclude "stddef.h"
+ text $
+ Text.pack $
+ printf
+ "\n_Static_assert(offsetof(%s, %s) == 0x%x, \"Offset wrong\");\n"
+ structName
+ regname
+ off
+
+sizeToType :: N Bytes -> Maybe String
+sizeToType = \case
+ 1 -> Just "uint8_t"
+ 2 -> Just "uint16_t"
+ 4 -> Just "uint32_t"
+ 8 -> Just "uint64_t"
+ _ -> Nothing
+
+selectByModifier :: Modifier f an -> (a, a) -> [a]
+selectByModifier mod (getter, setter) =
+ case mod of
+ (ModifierKeyword Rw _) -> [getter, setter]
+ (ModifierKeyword Ro _) -> [getter]
+ (ModifierKeyword Wo _) -> [setter]
+ (ModifierKeyword Pr _) -> []
+
+writeRegGet :: StructName -> QRegMetadata True -> FileM ()
+writeRegGet
+ structType
+ ( QRegMetadata
+ { regSpan =
+ Present
+ FieldSpan
+ { size = size
+ },
+ regFullPath = fullPath
+ }
+ ) = do
+ let fnName = "get_" <> qualifiedPathToIdentifier fullPath
+ returnType = sizeToType size
+ fieldName = NonEmpty.last fullPath
+
+ case returnType of
+ Just rt -> do
+ textM $ do
+ tell $
+ Text.pack $
+ printf "static inline %s %s(const %s* o) {\n" rt fnName structType
+ tell $ Text.pack $ printf " return o->%s;\n" fieldName
+ tell "}\n\n"
+ Nothing ->
+ -- Return type is not defined, fallback to byte-by-byte copy.
+ textM $ do
+ tell $
+ Text.pack $
+ printf
+ "static inline void %s(%s* o, uint8_t out[%d]) {\n"
+ fnName
+ structType
+ size
+ forM_ [0 .. size - 1] $ \i ->
+ tell $ Text.pack $ printf " out[%d] = o->%s[%d];\n" i fieldName i
+ tell "}\n\n"
+
+writeRegSet :: StructName -> QRegMetadata True -> FileM ()
+writeRegSet
+ structType
+ ( QRegMetadata
+ { regSpan =
+ Present
+ FieldSpan
+ { size = size
+ },
+ regFullPath = fullPath
+ }
+ ) = do
+ let fnName = "set_" <> qualifiedPathToIdentifier fullPath
+ setType = sizeToType size
+ fieldName = NonEmpty.last fullPath
+
+ case setType of
+ Just rt -> do
+ textM $ do
+ tell $
+ Text.pack $
+ printf "static inline void %s(%s* o, %s v) {\n" fnName structType rt
+ tell $ Text.pack $ printf " o->%s = v;\n" fieldName
+ tell "}\n\n"
+ Nothing ->
+ -- Return type is not defined, fallback to byte-by-byte copy.
+ textM $ do
+ tell $
+ Text.pack $
+ printf
+ "static inline void %s(%s* o, const uint8_t in[%d]) {\n"
+ fnName
+ structType
+ size
+ forM_ [0 .. size - 1] $ \i ->
+ tell $ Text.pack $ printf " o->%s[%d] = in[%d];\n" fieldName i i
+ tell "}\n\n"
+
+pattern DefinedBitsP :: String -> NonEmpty String -> N Bits -> RegisterBitsDecl Checked f a
+pattern DefinedBitsP bitsName bitsFullPath offset <-
+ ( DefinedBits
+ { qBitsMetadata =
+ Present
+ QBitsMetadata
+ { bitsSpan =
+ Present
+ FieldSpan
+ { offset = offset
+ },
+ bitsFullPath = (NonEmpty.last &&& id -> (bitsName, bitsFullPath))
+ }
+ }
+ )
+
+writeRegisterBody :: StructName -> QRegMetadata True -> RegisterBody Checked I A -> FileM ()
+writeRegisterBody structName regmeta = walk_ registerWalk
+ where
+ registerWalk :: forall t. (Walk t, Typeable t) => t I A -> FileM ()
+ registerWalk t = case () of
+ ()
+ | (Just (DefinedBitsP bitsName fullPath offset)) <- castTS t ->
+ text $
+ Text.pack $
+ printf
+ "// Emit bits %s (%s) at %d\n"
+ bitsName
+ (qualifiedPathToIdentifier fullPath)
+ offset
+ _ -> return ()
-structBody :: ObjTypeBody Checked I A -> FormattedWriter ()
-structBody (ObjTypeBody _ decls _) = do
+ castTS ::
+ forall (t' :: SynTree) (t :: StagedSynTree) (f :: Type -> Type) (a :: Type).
+ ( Typeable t',
+ Typeable t,
+ Typeable f,
+ Typeable a
+ ) =>
+ t' f a ->
+ Maybe (t Checked f a)
+ castTS = cast
+
+writeImplementation ::
+ StructName ->
+ QRegMetadata True ->
+ Modifier f a ->
+ Maybe (RegisterBody Checked I A) ->
+ FileM ()
+
+-- | Register is just padding, don't emit anything
+writeImplementation _ (regIsPadding -> True) _ _ = return ()
+writeImplementation structName qMeta mod bod = do
+ unless (regIsUnnamed qMeta) $
+ sequence_ $
+ selectByModifier mod (writeRegGet structName qMeta, writeRegSet structName qMeta)
+
+ mapM_ (writeRegisterBody structName qMeta) bod
+
+structBody :: StructName -> ObjTypeBody Checked I A -> FileM ()
+structBody structName (ObjTypeBody _ decls _) = do
forM_ decls $ \(Directed _ decl _) ->
case decl of
RegisterDecl
- { regSpan = Present (FieldSpan _ sz),
+ { qRegMeta = Present regMetadata,
regIdent = Guaranteed (identToString -> i),
+ regModifier = Guaranteed mod,
+ regBody = bod,
regAnnot = ann
} -> do
- emitDocComments ann
- tell (sizeToField i sz)
- tell ";\n"
- ReservedDecl
- { regSpan = Present (FieldSpan _ sz),
- reservedIdent = Present i,
- reservedAnnot = ann
- } -> do
- emitDocComments ann
- tell (sizeToField i sz)
- tell ";\n"
+ let (Present (FieldSpan off sz)) = regSpan regMetadata
+
+ textM $ do
+ emitDocComments ann
+ tell (sizeToField i sz)
+ tell ";\n"
+
+ under aF $
+ writeStaticAssert structName i off
+
+ under iF $
+ writeImplementation structName regMetadata mod bod
TypeSubStructure
{ subStructureBody = Identity bod,
subStructureName = mname
} -> do
- tell $ case objBodyType bod of
- Union {} -> "union "
- Struct {} -> "struct "
+ text $
+ case objBodyType bod of
+ Union {} -> "union "
+ Struct {} -> "struct "
- body $ structBody bod
+ body $ structBody structName bod
- forM_ mname $ \name ->
- tell (Text.pack $ identToString name)
+ textM $ do
+ forM_ mname $ \name ->
+ tell (Text.pack $ identToString name)
- tell ";\n"
+ tell ";\n"
where
sizeToField (Text.pack -> f) = \case
1 -> "volatile uint8_t " <> f
@@ -253,24 +491,24 @@ structBody (ObjTypeBody _ decls _) = do
8 -> "volatile uint64_t " <> f
n -> "volatile uint8_t " <> f <> "[" <> Text.pack (show n) <> "]"
-union :: Text -> FormattedWriter () -> FormattedWriter ()
+union :: Text -> FileM () -> FileM ()
union identifier fn = do
- tell "#pragma pack(push, 1)\n"
- tell $ "union " <> identifier <> " "
+ text "#pragma pack(push, 1)\n"
+ text $ "union " <> identifier <> " "
body fn
- tell ";\n"
- tell "#pragma pack(pop)\n"
+ text ";\n"
+ text "#pragma pack(pop)\n"
-struct :: Text -> FormattedWriter () -> FormattedWriter ()
+struct :: Text -> FileM () -> FileM ()
struct identifier fn = do
- tell "#pragma pack(push, 1)\n"
- tell $ "struct " <> identifier <> " "
+ text "#pragma pack(push, 1)\n"
+ text $ "struct " <> identifier <> " "
body fn
- tell ";\n"
- tell "#pragma pack(pop)\n"
+ text ";\n"
+ text "#pragma pack(pop)\n"
-body :: FormattedWriter a -> FormattedWriter a
-body f = tell "{\n" *> indented f <* (ensureNL >> tell "}")
+body :: FileM a -> FileM a
+body f = text "{\n" *> indented f <* textM (ensureNL >> tell "}")
identifierFor :: (ExportableDecl d) => d -> Text
identifierFor = qualifiedPathToIdentifier . metadataFullyQualifiedPath . getMetadata
@@ -313,14 +551,29 @@ transpileWalk _ headerFile t _ = case () of
Union {} -> union
Struct {} -> struct
- withFileAt headerFile middlePos $ do
- pad $ do
- emitDocComments a
- structureType (identifierFor (unwrap metadata)) $ do
- structBody objTypeBody
+ withFile headerFile $ do
+ under sF $ do
+ pad $ do
+ textM $ emitDocComments a
+ let structName = identifierFor (unwrap metadata)
+ structureType structName $ do
+ structBody structName objTypeBody
return Stop
+ () | Just (getExportedObjectDecl -> Just e) <- castTS t -> do
+ let qname = qualifiedPathToIdentifier (metadataFullyQualifiedPath (getMetadata e))
+ withFile headerFile $
+ under fF $ do
+ text "#define "
+ text qname
+ text $ Text.pack $ printf " ((%s*)0x%08x)\n" (toLiteralTypeName (exportedObjectDeclType e)) (exportedObjectDeclLocation e)
+
+ return Stop
_ -> return (Continue ())
where
+ toLiteralTypeName :: ReferencedObjectType -> Text
+ toLiteralTypeName (ReferencedObjectType str) = qualifiedPathToIdentifier str
+ toLiteralTypeName (ArrayObjectType ro _) = toLiteralTypeName ro
+
castTS ::
forall (t' :: SynTree) (t :: StagedSynTree) (f :: Type -> Type) (a :: Type).
( Typeable t',
@@ -331,3 +584,7 @@ transpileWalk _ headerFile t _ = case () of
t' f a ->
Maybe (t Checked f a)
castTS = cast
+
+ getExportedObjectDecl :: FiddleDecl Checked I A -> Maybe ExportedObjectDecl
+ getExportedObjectDecl (ObjectDecl {objectQualificationMetadata = Identity (Present decl)}) = Just decl
+ getExportedObjectDecl _ = Nothing
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 4be2912..3d95ea0 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -153,14 +153,15 @@ advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
assertedPos <- expressionToIntM expr
checkPositionAssertion (annot e) assertedPos offset
return (ret, offset)
- (RegisterDecl _ mod ident size Nothing a) -> do
+ (RegisterDecl qmeta mod ident size Nothing a) -> do
(sizeExpr, reifiedSize) <- advanceAndGetSize size
reifiedSizeBytes <- checkBitsSizeMod8 a reifiedSize
let span = Present (FieldSpan offset reifiedSizeBytes)
- doReturn (RegisterDecl span mod ident sizeExpr Nothing a)
+ qmeta' = fmap (\q -> q {regSpan = span}) qmeta
+ doReturn (RegisterDecl qmeta' mod ident sizeExpr Nothing a)
=<< checkBitsSizeMod8 a reifiedSize
- (RegisterDecl _ mod ident size (Just body) a) -> do
+ (RegisterDecl qmeta mod ident size (Just body) a) -> do
declaredSize <- expressionToIntM size
(actualSize, body') <- advanceRegisterBody body
@@ -170,12 +171,8 @@ advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
reifiedSizeBytes <- checkBitsSizeMod8 a reifiedSize
let span = Present (FieldSpan offset reifiedSizeBytes)
- doReturn (RegisterDecl span mod ident sizeExpr (Just body') a) reifiedSizeBytes
- (ReservedDecl _ i size a) -> do
- (sizeExpr, reifiedSize) <- advanceAndGetSize size
- reifiedSizeBytes <- checkBitsSizeMod8 a reifiedSize
- let span = Present (FieldSpan offset reifiedSizeBytes)
- doReturn (ReservedDecl span i sizeExpr a) reifiedSizeBytes
+ qmeta' = fmap (\q -> q {regSpan = span}) qmeta
+ doReturn (RegisterDecl qmeta' mod ident sizeExpr (Just body') a) reifiedSizeBytes
(TypeSubStructure (Identity body) name a) -> do
(size, body') <- advanceObjTypeBody body offset
doReturn (TypeSubStructure (Identity body') name a) size
@@ -245,11 +242,13 @@ advanceDecl offset = \case
<$> advanceStage () expr
<*> pure an
)
- DefinedBits _ mod ident typ annot -> do
+ DefinedBits qmeta mod ident typ annot -> do
size <- bitsTypeSize typ
let span = Present (FieldSpan offset size)
+ qmeta' = fmap (\q -> q {bitsSpan = span}) qmeta
+
(size,)
- <$> (DefinedBits span mod ident <$> advanceStage () typ <*> pure annot)
+ <$> (DefinedBits qmeta' mod ident <$> advanceStage () typ <*> pure annot)
BitsSubStructure subBody subName ann -> do
(sz, body') <- advanceRegisterBody subBody
return (sz, BitsSubStructure body' subName ann)
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index ce6250a..67d3f29 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -12,11 +12,11 @@ module Language.Fiddle.Compiler.Qualification (qualificationPhase) where
import Control.Monad.RWS (MonadWriter (tell))
import Control.Monad.State
-import Data.Foldable (foldlM)
+import Data.Foldable (foldlM, toList)
import Data.List (intercalate)
-import Data.List.NonEmpty (NonEmpty (..), toList)
+import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
-import Data.Maybe (mapMaybe)
+import Data.Maybe (isNothing, mapMaybe)
import qualified Data.Text
import Data.Word
import Language.Fiddle.Ast
@@ -52,11 +52,8 @@ uniqueString prefix = do
modify $ \g -> g {uniqueCounter = cnt + 1}
return $ "_" ++ prefix ++ show cnt
-uniqueIdentifier :: a -> M (Identifier F a)
-uniqueIdentifier a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString "ident"
-
-uniqueReservedIdentifier :: a -> M (Identifier F a)
-uniqueReservedIdentifier a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString "reserved"
+uniqueIdentifier :: String -> a -> M (Identifier F a)
+uniqueIdentifier prefix a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString prefix
instance CompilationStage Expanded where
type StageAfter Expanded = Qualified
@@ -77,14 +74,17 @@ qualificationPhase =
squeezeDiagnostics raw
--- Any non-guaranteed identifiers are given generated identifiers here.
-instance
- StageConvertible
- Expanded
- (Guaranteed False (Identifier F A))
- (Guaranteed True (Identifier F A))
- where
- convertInStage _ ann _ = guaranteeM (uniqueIdentifier ann)
+pushIdent :: Identifier f a -> LocalState -> LocalState
+pushIdent i = pushIdents [i]
+
+pushIdents :: (Foldable t) => t (Identifier f a) -> LocalState -> LocalState
+pushIdents =
+ ( \case
+ [] -> id
+ (i : is) ->
+ modifyCurrentScopePath (pushScope $ fmap identToString (i :| is))
+ )
+ . toList
instance
StageConvertible
@@ -110,9 +110,80 @@ deriving instance AdvanceStage S EnumBody
deriving instance AdvanceStage S EnumConstantDecl
-deriving instance AdvanceStage S RegisterBitsDecl
-
-deriving instance AdvanceStage S ObjTypeDecl
+instance AdvanceStage S RegisterBitsDecl where
+ advanceStage localState = \case
+ ReservedBits expr an -> ReservedBits <$> advanceStage localState expr <*> pure an
+ BitsSubStructure bod name an ->
+ BitsSubStructure
+ <$> advanceStage localState bod
+ <*> pure name
+ <*> pure an
+ DefinedBits _ mod ident typ an -> do
+ let qMeta =
+ QBitsMetadata
+ { bitsSpan = Vacant,
+ bitsFullPath =
+ qualifyPath
+ (currentScopePath localState)
+ (NonEmpty.singleton (identToString ident))
+ }
+ DefinedBits (Present qMeta) mod ident
+ <$> advanceStage localState typ
+ <*> pure an
+
+instance AdvanceStage S ObjTypeDecl where
+ advanceStage localState = \case
+ AssertPosStatement d e a ->
+ AssertPosStatement d <$> advanceStage localState e <*> pure a
+ RegisterDecl _ mod ident size bod ann -> do
+ ident' <- guaranteeM (uniqueIdentifier "reg" ann) ident
+ let localState' = pushIdents ident localState
+
+ let qRegMeta =
+ QRegMetadata
+ { regSpan = Vacant,
+ regIsPadding = False,
+ regIsUnnamed = isNothing (toMaybe ident),
+ regFullPath =
+ qualifyPath
+ (currentScopePath localState)
+ (NonEmpty.singleton (identToString (unwrap ident')))
+ }
+
+ RegisterDecl
+ (Present qRegMeta)
+ (guarantee (ModifierKeyword Rw ann) mod)
+ ident'
+ <$> advanceStage localState' size
+ <*> mapM (advanceStage localState') bod
+ <*> pure ann
+ ReservedDecl _ expr ann -> do
+ ident <- uniqueIdentifier "reserved" ann
+
+ let qRegMeta =
+ QRegMetadata
+ { regSpan = Vacant,
+ regIsPadding = True,
+ regIsUnnamed = True,
+ regFullPath =
+ qualifyPath
+ (currentScopePath localState)
+ (NonEmpty.singleton (identToString ident))
+ }
+
+ RegisterDecl
+ (Present qRegMeta)
+ (Guaranteed $ ModifierKeyword Pr ann)
+ (Guaranteed ident)
+ <$> advanceStage localState expr
+ <*> pure Nothing
+ <*> pure ann
+ TypeSubStructure bod name an -> do
+ let localState' = pushIdents name localState
+ TypeSubStructure
+ <$> mapM (advanceStage localState') bod
+ <*> pure name
+ <*> pure an
deriving instance AdvanceStage S (Expression u)
@@ -284,6 +355,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
<*> pure ann
ObjTypeDecl _ ident body ann ->
let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
+ localState'' = modifyCurrentScopePath (pushScope (NonEmpty.singleton $ identToString ident)) localState'
in do
typeSize <- calculateTypeSize =<< resolveOrFail body
let decl =
@@ -295,7 +367,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
=<< ObjTypeDecl
(qMd decl)
ident
- <$> mapM (advanceStage localState') body
+ <$> mapM (advanceStage localState'') body
<*> pure ann
ObjectDecl _ ident loc typ ann ->
let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
@@ -331,7 +403,9 @@ objTypeToExport ls = \case
<*> expressionToIntM size
ReferencedObjType {refName = n} -> do
(full, _ :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls
- return $ ReferencedObjectType (intercalate "." full)
+ case full of
+ (f:fs) -> return $ ReferencedObjectType (f :| fs)
+ _ -> compilationFailure
calculateTypeSize :: ObjTypeBody Expanded F A -> M (N Bytes)
calculateTypeSize (ObjTypeBody bodyType decls _) =
generated by cgit (git 2.34.1) at 2025-07-15 21:56:52 +0000