diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Language/Fiddle/Compiler/Backend/C.hs | 481 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Backend/Internal/FormattedWriter.hs | 72 | ||||
| -rw-r--r-- | src/Language/Fiddle/Internal/UnitInterface.hs | 6 | ||||
| -rw-r--r-- | src/Language/Fiddle/Parser.hs | 2 |
4 files changed, 414 insertions, 147 deletions
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs index 71344c5..26ea065 100644 --- a/src/Language/Fiddle/Compiler/Backend/C.hs +++ b/src/Language/Fiddle/Compiler/Backend/C.hs @@ -7,16 +7,18 @@ module Language.Fiddle.Compiler.Backend.C (cBackend) where import Control.Arrow -import Control.Monad (unless) +import Control.Monad (forM, unless) import Control.Monad.RWS +import Control.Monad.Trans.Writer hiding (tell) import qualified Data.Bits import Data.Char (isSpace) import Data.Data (Typeable, cast) import Data.Foldable (forM_) import Data.Kind (Type) +import qualified Data.List import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -34,17 +36,80 @@ import Numeric (showHex) import Options.Applicative import Text.Printf (printf) -data ImplementationInHeader = ImplementationInHeader +newtype CBackendFlags = CBackendFlags + { cHeaderOut :: FilePath + } -data CBackendFlags = CBackendFlags - { cSourceOut :: Either ImplementationInHeader FilePath, - cHeaderOut :: FilePath +data SIntfF + = SIntfF + { sIntfFValue :: Text, + sIntfFComemnts :: FormattedWriter () } --- data StructureInterface = Leaf String String +newtype SIntf + = SIntf + ( Map String (Either SIntfF SIntf) + ) + +instance Monoid SIntf where + mempty = SIntf mempty + +instance Semigroup SIntf where + (<>) (SIntf m1) (SIntf m2) = + SIntf $ + Map.unionWith + ( \a b -> case (a, b) of + (Right a, Right b) -> Right (a <> b) + (Left _, Left b) -> Left b + (Right a, Left _) -> Right a + (_, Right a) -> Right a + ) + m1 + m2 + +class SIntfSingleton a where + sIntfSingleton :: String -> a -> SIntf + +instance SIntfSingleton SIntfF where + sIntfSingleton s = SIntf . Map.singleton s . Left + +instance SIntfSingleton SIntf where + sIntfSingleton s = SIntf . Map.singleton s . Right type StructName = Text +sIntfToC :: SIntf -> M () +sIntfToC (SIntf m) = do + text "struct " + body $ + forM_ (Map.toList m) $ \(k, v) -> do + case v of + Left (SIntfF txt emitCom) -> do + textM emitCom + text $ "typeof(" <> txt <> ")* " <> Text.pack k <> ";\n" + Right sub -> do + sIntfToC sub + text " " + text $ Text.pack k + text ";\n" + +sIntfToRVal :: SIntf -> M () +sIntfToRVal (SIntf m) = do + body $ do + sequence_ $ + Data.List.intersperse (text ",\n") $ + map + ( \(k, v) -> do + case v of + Left (SIntfF txt _) -> + text $ "." <> Text.pack k <> " = " <> txt + Right sub -> do + text $ "." <> Text.pack k <> " = " + sIntfToRVal sub + ) + (Map.toList m) + text "\n" + -- | Header fragment. The top. Starts which include guards and has include -- statements. hF :: FileFragment @@ -66,6 +131,10 @@ aF = ("HEADER", FragTree.below (snd sF)) fF :: FileFragment fF = ("HEADER", FragTree.below FragTree.center) +-- | Interface fragment. This is wehre interfaces are stored. +intfF :: FileFragment +intfF = ("HEADER", FragTree.above (snd fF)) + type A = Commented SourceSpan type I = Identity @@ -92,20 +161,7 @@ cBackend = { backendName = "C", backendOptionsParser = CBackendFlags - <$> ( Right - <$> strOption - ( long "c-source-out" - <> short 'o' - <> help "Output file for the C source file." - <> metavar "OUTPUT" - ) - <|> flag' - (Left ImplementationInHeader) - ( long "impl-in-header" - <> help "Put the whole implementation as static inline functions in the header." - ) - ) - <*> strOption + <$> strOption ( long "c-header-out" <> short 'h' <> help "Output file for the C header file." @@ -122,8 +178,7 @@ transpile :: TranspileResult transpile CBackendFlags - { cHeaderOut = headerFile, - cSourceOut = sourceFile + { cHeaderOut = headerFile } () fiddleUnit = toTranspileResult $ fst $ runFilesM execFormattedWriter () (CFileState mempty) hF run @@ -133,7 +188,6 @@ transpile TranspileResult $ Map.mapKeys ( \case - "SOURCE" | Right sourceFile' <- sourceFile -> sourceFile' "HEADER" -> headerFile k -> k ) @@ -149,11 +203,11 @@ transpile -- Pad out the implementation checkout iF $ text "\n" - walk (transpileWalk sourceFile headerFile) fiddleUnit () + walk (transpileWalk headerFile) fiddleUnit () checkout hF $ textM $ do - tell "\nstatic_assert(true); // https://github.com/clangd/clangd/issues/1167\n" + tell "\n_Static_assert(1); // https://github.com/clangd/clangd/issues/1167\n" checkout fF $ text headerFinal @@ -187,7 +241,7 @@ writeStaticAssert structName regname off = do text $ Text.pack $ printf - "\n_Static_assert(offsetof(%s, %s) == 0x%x, \"Offset wrong\");\n" + "\n_Static_assert(offsetof(struct %s, %s) == 0x%x, \"Offset wrong\");\n" structName regname off @@ -208,7 +262,7 @@ selectByModifier mod (getter, setter) = (ModifierKeyword Wo _) -> [setter] (ModifierKeyword Pr _) -> [] -writeRegGet :: StructName -> QRegMetadata True -> M () +writeRegGet :: StructName -> QRegMetadata True -> A -> M SIntf writeRegGet structType ( QRegMetadata @@ -219,7 +273,7 @@ writeRegGet }, regFullPath = fullPath } - ) = do + ) docComms = do let fnName = qualifiedPathToIdentifier fullPath <> "__get" returnType = sizeToType size fieldName = basenamePart fullPath @@ -229,7 +283,7 @@ writeRegGet textM $ do tell $ Text.pack $ - printf "static inline %s %s(const %s* o) {\n" rt fnName structType + printf "static inline %s %s(const struct %s* o) {\n" rt fnName structType tell $ Text.pack $ printf " return o->%s;\n" fieldName tell "}\n\n" Nothing -> @@ -246,7 +300,9 @@ writeRegGet tell $ Text.pack $ printf " out[%d] = o->%s[%d];\n" i fieldName i tell "}\n\n" -writeRegSet :: StructName -> QRegMetadata True -> M () + return $ sIntfSingleton "get" (SIntfF fnName (emitDocComments docComms)) + +writeRegSet :: StructName -> QRegMetadata True -> A -> M SIntf writeRegSet structType ( QRegMetadata @@ -257,7 +313,7 @@ writeRegSet }, regFullPath = fullPath } - ) = do + ) docComs = do let fnName = qualifiedPathToIdentifier fullPath <> "__set" setType = sizeToType size fieldName = basenamePart fullPath @@ -284,14 +340,17 @@ writeRegSet tell $ Text.pack $ printf " o->%s[%d] = in[%d];\n" fieldName i i tell "}\n\n" + return $ sIntfSingleton "set" (SIntfF fnName (emitDocComments docComs)) + pattern DefinedBitsP :: Modifier f a -> String -> QualifiedPath String -> N Bits -> - RegisterBitsTypeRef Checked f a -> - RegisterBitsDecl Checked f a -pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef <- + RegisterBitsTypeRef Checked f A -> + A -> + RegisterBitsDecl Checked f A +pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef annot <- ( DefinedBits { qBitsMetadata = Present @@ -304,7 +363,8 @@ pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef <- bitsFullPath = (basenamePart &&& id -> (bitsName, bitsFullPath)) }, definedBitsTypeRef = typeRef, - definedBitsModifier = (Guaranteed modifier) + definedBitsModifier = (Guaranteed modifier), + definedBitsAnnot = annot } ) @@ -314,20 +374,115 @@ writeBitsGet :: QualifiedPath String -> N Bits -> RegisterBitsTypeRef 'Checked I A -> - M () -writeBitsGet _ _ _ _ _ = return () + A -> + M SIntf +writeBitsGet structName regName fullPath offset typeRef docComms = do + let fnName = qualifiedPathToIdentifier fullPath <> "__get" + bitsName = basenamePart fullPath + retType = typeRefBaseType typeRef + + text $ "inline static " <> retType <> " " + text fnName + text "(\n struct " + text structName + text " *o" + + let shiftArguments = + zipWith + (\a b -> if b == 1 then a else a <> " * " <> s b) + (tail setterArgumentNames) + (snd $ offsetCoefficients typeRef) + ++ [s offset | offset /= 0] + + unless (null shiftArguments) $ + text ", " + + text $ Text.intercalate ", " $ zipWith (\f _ -> "int " <> f) (tail setterArgumentNames) shiftArguments + + text ") {\n" + + withIndent $ do + if null shiftArguments + then do + text "unsigned shift_ = 0" + else do + text "unsigned shift_ = " + text $ Text.intercalate " + " shiftArguments + text ";\n" + + text "unsigned mask_ = " + text $ typeRefToGetMask typeRef + text " << shift_;\n" + + text $ retType <> " ret = (" <> retType <> ")((o->" <> Text.pack regName <> " & mask_) >> shift_);\n" + text "return ret;\n" + text "}\n\n" + return $ + sIntfSingleton bitsName $ + sIntfSingleton "get" (SIntfF fnName (emitDocComments docComms)) + where + offsetCoefficients :: RegisterBitsTypeRef Checked I A -> (Int, [Int]) + offsetCoefficients + RegisterBitsJustBits + { justBitsExpr = fromIntegral . trueValue -> sz + } = (sz, []) + offsetCoefficients + RegisterBitsReference + { bitsRefQualificationMetadata = + Identity + ( Present + ( ExportedBitsDecl + { exportedBitsDeclSizeBits = sz + } + ) + ) + } = (fromIntegral sz, []) + offsetCoefficients (RegisterBitsArray tr n _) = + let (recsz, rest) = offsetCoefficients tr + in ( recsz * fromIntegral (trueValue n), + rest ++ [recsz] + ) + + s :: (Show a) => a -> Text + s = Text.pack . show + + typeRefToGetMask :: RegisterBitsTypeRef Checked I a -> Text + typeRefToGetMask RegisterBitsArray {bitsArrayTypeRef = ref} = typeRefToGetMask ref + typeRefToGetMask + RegisterBitsJustBits + { justBitsExpr = fromIntegral . trueValue -> sz + } = "0x" <> Text.pack (showHex (((1 :: Int) `Data.Bits.shiftL` (sz :: Int)) - 1) "") + typeRefToGetMask + RegisterBitsReference + { bitsRefQualificationMetadata = + Identity + ( Present + ( ExportedBitsDecl + { exportedBitsDeclSizeBits = sz + } + ) + ) + } = + let num :: Int + num = (1 `Data.Bits.shiftL` fromIntegral sz) - 1 + in "0x" <> Text.pack (showHex num "") writeBitsSet :: + Bool -> StructName -> String -> QualifiedPath String -> N Bits -> RegisterBitsTypeRef 'Checked I A -> - M () -writeBitsSet structName bitsName fullPath offset typeRef = do + A -> + M SIntf +writeBitsSet writeOnly structName regName fullPath offset typeRef docComms = do + let fnName = qualifiedPathToIdentifier fullPath <> "__set" + bitsName = basenamePart fullPath + text "inline static void " - text (qualifiedPathToIdentifier fullPath) - text "__set(\n struct " + text fnName + text "(\n struct " text structName text " *o,\n " typeRefToArgs typeRef @@ -341,17 +496,30 @@ writeBitsSet structName bitsName fullPath offset typeRef = do ++ [s offset | offset /= 0] withIndent $ do - text $ maskValue typeRef - - text "int to_set = value" + let mask = typeRefToMask typeRef + text $ "unsigned mask_ = " <> mask <> ";\n" unless (null shiftArguments) $ do - text " << " - text $ Text.intercalate " + " shiftArguments + text $ + "unsigned shift_ = " <> Text.intercalate " + " shiftArguments <> ";\n" + text "mask_ <<= shift_;\n" + text "int to_set_ = value" + + unless (null shiftArguments) $ do + text " << shift_" text ";\n" - text $ "o->" <> Text.pack bitsName <> " = to_set;\n" + text "to_set_ &= mask_;\n" + + unless writeOnly $ do + text $ "unsigned current_ = o->" <> Text.pack regName <> ";\n" + text "to_set_ = current_ ^ (current_ & mask_) ^ to_set_;\n" + + text $ "o->" <> Text.pack regName <> " = to_set_;\n" text "}\n\n" + return $ + sIntfSingleton bitsName $ + sIntfSingleton "set" (SIntfF fnName (emitDocComments docComms)) where offsetCoefficients :: RegisterBitsTypeRef Checked I A -> (Int, [Int]) offsetCoefficients @@ -378,15 +546,12 @@ writeBitsSet structName bitsName fullPath offset typeRef = do s :: (Show a) => a -> Text s = Text.pack . show - maskValue ref = do - typeRefToMask ref - typeRefToMask :: RegisterBitsTypeRef Checked I a -> Text typeRefToMask RegisterBitsArray {bitsArrayTypeRef = ref} = typeRefToMask ref typeRefToMask RegisterBitsJustBits { justBitsExpr = fromIntegral . trueValue -> sz - } = "value &= 0x" <> Text.pack (showHex (((1 :: Int) `Data.Bits.shiftL` (sz :: Int)) - 1) "") <> ";\n" + } = "0x" <> Text.pack (showHex (((1 :: Int) `Data.Bits.shiftL` (sz :: Int)) - 1) "") typeRefToMask RegisterBitsReference { bitsRefQualificationMetadata = @@ -400,33 +565,26 @@ writeBitsSet structName bitsName fullPath offset typeRef = do } = let num :: Int num = (1 `Data.Bits.shiftL` fromIntegral sz) - 1 - in "value = (typeof(value))(value & 0x" <> Text.pack (showHex num "") <> ");\n" + in "0x" <> Text.pack (showHex num "") -typeRefToArgs :: RegisterBitsTypeRef 'Checked I A -> M () -typeRefToArgs reg = - text - $ Text.intercalate ",\n " - $ zipWith - (\n t -> t <> " " <> n) - setterArgumentNames - $ typeRefToArgs' reg +typeRefBaseType :: RegisterBitsTypeRef 'Checked I A -> Text +typeRefBaseType = typeRefBaseType' where - typeRefToArgs' + typeRefBaseType' ( RegisterBitsJustBits { justBitsExpr = ConstExpression (LeftV v) _ } - ) = [typeForBits v] - typeRefToArgs' + ) = typeForBits v + typeRefBaseType' ( RegisterBitsReference { bitsRefQualificationMetadata = (Identity (Present md)) } ) = - [ "enum " - <> qualifiedPathToIdentifier - (metadataFullyQualifiedPath $ getMetadata md) - ] - typeRefToArgs' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) = - typeRefToArgs' tr ++ ["int"] + "enum " + <> qualifiedPathToIdentifier + (metadataFullyQualifiedPath $ getMetadata md) + typeRefBaseType' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) = + typeRefBaseType' tr typeForBits = \case 64 -> "uint64_t" @@ -435,26 +593,48 @@ typeRefToArgs reg = 8 -> "uint8_t" _ -> "unsigned" +typeRefToArgs :: RegisterBitsTypeRef 'Checked I A -> M () +typeRefToArgs reg = + text + $ Text.intercalate ",\n " + $ zipWith + (\n t -> t <> " " <> n) + setterArgumentNames + $ typeRefToArgs' reg + where + typeRefToArgs' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) = + typeRefToArgs' tr ++ ["int"] + typeRefToArgs' x = [typeRefBaseType x] + -- | Decomposes a type ref into a type name (String) and a list of dimensions -- (in the case of being an array) -- decomposeBitsTypeRef :: RegisterBitsTypeRef Checked I A -> (String, [N Unitless]) -- decomposeBitsTypeRef (RegisterBitsJustBits ) -writeRegisterBody :: StructName -> QRegMetadata True -> RegisterBody Checked I A -> M () -writeRegisterBody structName regmeta = walk_ registerWalk +writeRegisterBody :: + StructName -> QRegMetadata True -> RegisterBody Checked I A -> M SIntf +writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk where regName = basenamePart (regFullPath regmeta) - registerWalk :: forall t. (Walk t, Typeable t) => t I A -> M () + registerWalk :: + forall t. + (Walk t, Typeable t) => + t I A -> + WriterT SIntf (FilesM () FormattedWriter CFileState) () registerWalk t = case () of () - | (Just (DefinedBitsP modifier _ fullPath offset typeRef)) <- castTS t -> do - sequence_ $ - selectByModifier - modifier - ( writeBitsGet structName regName fullPath offset typeRef, - writeBitsSet structName regName fullPath offset typeRef - ) - + | (Just (DefinedBitsP modifier _ fullPath offset typeRef annot)) <- castTS t -> + let isWo = case modifier of + ModifierKeyword Wo _ -> True + _ -> False + in do + lift $ textM $ emitDocComments annot + sequence_ $ + selectByModifier + modifier + ( tell =<< lift (writeBitsGet structName regName fullPath offset typeRef annot), + tell =<< lift (writeBitsSet isWo structName regName fullPath offset typeRef annot) + ) -- text $ -- Text.pack $ -- printf @@ -480,20 +660,30 @@ writeImplementation :: QRegMetadata True -> Modifier f a -> Maybe (RegisterBody Checked I A) -> - M () + A -> + M SIntf -- | 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 -> M () +writeImplementation _ (regIsPadding -> True) _ _ _ = return mempty +writeImplementation structName qMeta mod bod regAnnot = do + si1 <- + if regIsUnnamed qMeta + then return mempty + else do + l <- + sequence $ + selectByModifier + mod + (writeRegGet structName qMeta regAnnot, writeRegSet structName qMeta regAnnot) + return $ mconcat l + + si2 <- mapM (writeRegisterBody structName qMeta) bod + + return $ si1 <> fromMaybe mempty si2 + +structBody :: StructName -> ObjTypeBody Checked I A -> M SIntf structBody structName (ObjTypeBody _ decls _) = do - forM_ decls $ \(Directed _ decl _) -> + fmap mconcat $ forM decls $ \(Directed _ decl _) -> case decl of RegisterDecl { qRegMeta = Present regMetadata, @@ -513,7 +703,8 @@ structBody structName (ObjTypeBody _ decls _) = do writeStaticAssert structName i off checkout iF $ - writeImplementation structName regMetadata mod bod + (if regIsUnnamed regMetadata then id else sIntfSingleton i) + <$> writeImplementation structName regMetadata mod bod ann TypeSubStructure { subStructureBody = Identity bod, subStructureName = mname @@ -523,13 +714,15 @@ structBody structName (ObjTypeBody _ decls _) = do Union {} -> "union " Struct {} -> "struct " - body $ structBody structName bod + sintf <- body $ structBody structName bod textM $ do forM_ mname $ \name -> tell (Text.pack $ identToString name) tell ";\n" + + return sintf where sizeToField (Text.pack -> f) = \case 1 -> "volatile uint8_t " <> f @@ -538,21 +731,23 @@ structBody structName (ObjTypeBody _ decls _) = do 8 -> "volatile uint64_t " <> f n -> "volatile uint8_t " <> f <> "[" <> Text.pack (show n) <> "]" -union :: Text -> M () -> M () +union :: Text -> M a -> M a union identifier fn = do text "#pragma pack(push, 1)\n" text $ "union " <> identifier <> " " - body fn + a <- body fn text ";\n" text "#pragma pack(pop)\n" + return a -struct :: Text -> M () -> M () +struct :: Text -> M a -> M a struct identifier fn = do text "#pragma pack(push, 1)\n" text $ "struct " <> identifier <> " " - body fn + a <- body fn text ";\n" text "#pragma pack(pop)\n" + return a body :: M a -> M a body f = text "{\n" *> withIndent f <* textM (ensureNL >> tell "}") @@ -560,18 +755,24 @@ body f = text "{\n" *> withIndent f <* textM (ensureNL >> tell "}") withIndent :: M a -> M a withIndent = block incIndent decIndent +withCMacroMode :: M a -> M a +withCMacroMode = block cMacroModeStart cMacroModeStop + identifierFor :: (ExportableDecl d) => d -> Text identifierFor = qualifiedPathToIdentifier . metadataFullyQualifiedPath . getMetadata emitDocComments :: A -> FormattedWriter () emitDocComments (Commented comments _) = do - mapM_ (\t -> tellLn $ "// " <> t) $ - mapMaybe - ( \case - (DocComment t) -> Just (trimDocComment t) - _ -> Nothing - ) - comments + mapM_ (\t -> tellLn $ "// " <> trimDocComment t) $ + filter (not . Text.all isSpace) $ + Text.lines $ + mconcat $ + mapMaybe + ( \case + (DocComment t) -> Just t + _ -> Nothing + ) + comments ensureNL where trimDocComment = @@ -586,12 +787,12 @@ emitDocComments (Commented comments _) = do then Text.tail t else t -getEnumConstants :: [EnumConstantDecl Checked I a] -> [(String, N Unitless)] +getEnumConstants :: [Directed EnumConstantDecl Checked I a] -> [(String, N Unitless, [Directive I a])] getEnumConstants = mapMaybe $ \case - EnumConstantDecl (identToString -> str) (trueValue -> val) _ -> Just (str, val) + Directed dirs (EnumConstantDecl (identToString -> str) (trueValue -> val) _) _ -> Just (str, val, dirs) _ -> Nothing -pattern EnumPattern :: QualifiedPath String -> [(String, N Unitless)] -> FiddleDecl Checked I a +pattern EnumPattern :: QualifiedPath String -> [(String, N Unitless, [Directive I a])] -> FiddleDecl Checked I a pattern EnumPattern qualifiedPath consts <- BitsDecl { bitsQualificationMetadata = @@ -610,26 +811,50 @@ pattern EnumPattern qualifiedPath consts <- { enumBitBody = Identity ( EnumBody - { enumConsts = getEnumConstants . map undirected -> consts + { enumConsts = getEnumConstants -> consts } ) } } -emitEnum :: QualifiedPath String -> [(String, N Unitless)] -> M () +emitEnum :: QualifiedPath String -> [(String, N Unitless, [Directive I A])] -> M () emitEnum (qualifiedPathToIdentifier -> ident) consts = do text $ "enum " <> ident <> " " body $ do - forM_ consts $ \(name, val) -> do - text $ - ident <> "__" <> Text.pack name <> " = " <> Text.pack (show val) <> ",\n" + forM_ consts $ \(name, val, dirs) -> do + if isUnqualified dirs + then + text $ Text.pack name <> " = " <> Text.pack (show val) <> ",\n" + else + text $ + ident <> "__" <> Text.pack name <> " = " <> Text.pack (show val) <> ",\n" text ";\n\n" + where + isUnqualified = + any + ( any + ( \case + (DirectiveElementKey {directiveKey = identToString -> "unqualified"}) -> True + _ -> False + ) + . allElements + ) + + allElements + ( Directive + { directiveBody = + Identity + ( DirectiveBody + { directiveElements = elts + } + ) + } + ) = elts transpileWalk :: - Either ImplementationInHeader FilePath -> FilePath -> (forall t. (Walk t, Typeable t) => t I A -> () -> M (WalkContinuation ())) -transpileWalk _ headerFile t _ = case () of +transpileWalk headerFile t _ = case () of () | Just ( ObjTypeDecl @@ -647,15 +872,16 @@ transpileWalk _ headerFile t _ = case () of pad $ do textM $ emitDocComments a let structName = identifierFor (unwrap metadata) - structureType structName $ do + sh <- structureType structName $ do structBody structName objTypeBody + writeSIntf (metadataFullyQualifiedPath $ getMetadata (unwrap metadata)) sh return Stop () | Just (getExportedObjectDecl -> Just e) <- castTS t -> do let qname = qualifiedPathToIdentifier (metadataFullyQualifiedPath (getMetadata e)) checkout fF $ do text "#define " text qname - text $ Text.pack $ printf " ((%s*)0x%08x)\n" (toLiteralTypeName (exportedObjectDeclType e)) (exportedObjectDeclLocation e) + text $ Text.pack $ printf " ((struct %s*)0x%08x)\n" (toLiteralTypeName (exportedObjectDeclType e)) (exportedObjectDeclLocation e) return Stop () | Just (EnumPattern path consts) <- castTS t -> do @@ -683,6 +909,27 @@ transpileWalk _ headerFile t _ = case () of Maybe (t Checked f a) castTS = cast + writeSIntf :: QualifiedPath String -> SIntf -> M () + writeSIntf qp si = do + let typename = qualifiedPathToIdentifier qp <> "__intf" + + checkout intfF $ do + text "typedef " + sIntfToC si + text $ " " <> typename <> ";\n\n" + + withCMacroMode $ do + text $ + "#define " + <> Text.toUpper (qualifiedPathToIdentifier qp) + <> "_INTF ((" + <> typename + <> ")" + sIntfToRVal si + text ")" + + text "\n\n" + getExportedObjectDecl :: FiddleDecl Checked I A -> Maybe ExportedObjectDecl getExportedObjectDecl (ObjectDecl {objectQualificationMetadata = Identity (Present decl)}) = Just decl getExportedObjectDecl _ = Nothing diff --git a/src/Language/Fiddle/Compiler/Backend/Internal/FormattedWriter.hs b/src/Language/Fiddle/Compiler/Backend/Internal/FormattedWriter.hs index bde9ebe..000dfa4 100644 --- a/src/Language/Fiddle/Compiler/Backend/Internal/FormattedWriter.hs +++ b/src/Language/Fiddle/Compiler/Backend/Internal/FormattedWriter.hs @@ -3,21 +3,30 @@ {-# LANGUAGE OverloadedStrings #-} -- | This module provides the 'FormattedWriter' monad, which extends a basic --- "Writer" over 'Text' by allowing formatting features like indentation, line --- breaks, and ensuring the output is well-structured for readability. --- +-- "Writer" over 'Text' by allowing formatting features like indentation, line +-- breaks, and ensuring the output is well-structured for readability. +-- -- The 'FormattedWriter' is useful for generating pretty-printed output, such as -- source code generation, where indentation and newline management are essential. module Language.Fiddle.Compiler.Backend.Internal.FormattedWriter ( -- * Types - FormattedWriter, -- | The main writer monad with formatting features. + FormattedWriter, + -- | The main writer monad with formatting features. -- * Core Operations - ensureNL, -- | Ensures that there is a newline at the end of the current line. - flush, -- | Flushes any pending text (writes the pending line). - incIndent, -- | Increases the indentation level. - decIndent, -- | Decreases the indentation level. - indented, -- | Performs an action with increased indentation. - execFormattedWriter, -- | Runs the 'FormattedWriter' and produces the final formatted 'Text'. + ensureNL, + -- | Ensures that there is a newline at the end of the current line. + flush, + -- | Flushes any pending text (writes the pending line). + incIndent, + -- | Increases the indentation level. + decIndent, + -- | Decreases the indentation level. + indented, + -- | Performs an action with increased indentation. + execFormattedWriter, + -- | Runs the 'FormattedWriter' and produces the final formatted 'Text'. + cMacroModeStart, + cMacroModeStop, ) where @@ -27,12 +36,15 @@ import Data.Text (Text) import qualified Data.Text as Text -- | Internal state for the 'FormattedWriter' monad. --- +-- -- * 'indentLevel': The current level of indentation. -- * 'pendingLine': The current line that is being built but not yet written. data Fmt = Fmt - { indentLevel :: Int, -- ^ Current indentation level. - pendingLine :: Text -- ^ Text that has been added but not yet written to the output. + { -- | Current indentation level. + indentLevel :: Int, + linePost :: Text, + -- | Text that has been added but not yet written to the output. + pendingLine :: Text } -- | The 'FormattedWriter' is a monad that provides functionality for writing @@ -52,12 +64,14 @@ instance MonadWriter Text FormattedWriter where -- For each line, write the indent, the pending line, and then the line itself. forM_ (Prelude.init lines) $ \line -> do pending <- gets pendingLine - modify $ \s -> s {pendingLine = ""} -- Reset pending line - tell indent -- Add indentation + lp <- gets linePost + modify $ \s -> s {pendingLine = ""} -- Reset pending line + tell indent -- Add indentation tell pending -- Write any pending text - tell line -- Write the actual line - tell "\n" -- Add a newline after the line - -- The last fragment is kept as the new pending line, to be written later. + tell line -- Write the actual line + tell lp + tell "\n" -- Add a newline after the line + -- The last fragment is kept as the new pending line, to be written later. modify $ \s -> s {pendingLine = pendingLine s <> Prelude.last lines} -- Allow listening to the written text within the 'FormattedWriter' context. @@ -85,29 +99,35 @@ flush :: FormattedWriter () flush = do p <- gets pendingLine modify $ \s -> s {pendingLine = ""} - tell p + lp <- gets linePost + tell (p <> lp) -- | Increases the indentation level by one. This will affect all subsequent -- lines written within the 'FormattedWriter' monad. incIndent :: FormattedWriter () -incIndent = modify (\(Fmt id p) -> Fmt (id + 1) p) +incIndent = modify (\f -> f {indentLevel = indentLevel f + 1}) -- | Decreases the indentation level by one. This will affect all subsequent -- lines written within the 'FormattedWriter' monad. decIndent :: FormattedWriter () -decIndent = modify (\(Fmt id p) -> Fmt (id - 1) p) +decIndent = modify (\f -> f {indentLevel = indentLevel f - 1}) + +cMacroModeStart :: FormattedWriter () +cMacroModeStart = modify (\f -> f { linePost = " \\" }) + +cMacroModeStop :: FormattedWriter () +cMacroModeStop = modify (\f -> f { linePost = "" }) -- | Runs the given 'FormattedWriter' action with an additional indentation level. -- Once the action completes, the indentation level is decreased. indented :: FormattedWriter () -> FormattedWriter () indented fn = do - incIndent -- Increase indentation level - fn -- Run the action with the increased indentation - decIndent -- Restore the original indentation level + incIndent -- Increase indentation level + fn -- Run the action with the increased indentation + decIndent -- Restore the original indentation level -- | Runs a 'FormattedWriter' and returns the final formatted 'Text' output. -- It ensures that any pending lines are flushed before returning the result. execFormattedWriter :: FormattedWriter a -> Text execFormattedWriter ((>> flush) -> FormattedWriter rws) = - snd $ execRWS rws () (Fmt 0 "") -- Execute the RWS monad, starting with no indentation and no pending line. - + snd $ execRWS rws () (Fmt 0 "" "") -- Execute the RWS monad, starting with no indentation and no pending line. diff --git a/src/Language/Fiddle/Internal/UnitInterface.hs b/src/Language/Fiddle/Internal/UnitInterface.hs index 26b0875..465741f 100644 --- a/src/Language/Fiddle/Internal/UnitInterface.hs +++ b/src/Language/Fiddle/Internal/UnitInterface.hs @@ -27,13 +27,13 @@ data InternalDirectiveExpression data InternalDirective = InternalDirective { -- | Specifies the backend that this directive is intended for. If 'Nothing', -- the directive applies globally across all backends. - directiveBackend :: Maybe String, + internalDirectiveBackend :: Maybe String, -- | The key or name of the directive. This identifies the directive's -- purpose, such as enabling specific features or setting options. - directiveKey :: String, + internalDirectiveKey :: String, -- | The optional value associated with this directive. Some directives -- may not require a value (e.g., flags), in which case this field is 'Nothing'. - directiveValue :: Maybe InternalDirectiveExpression + internalDirectiveValue :: Maybe InternalDirectiveExpression } deriving (Generic, ToJSON, FromJSON, Show, Eq, Ord) diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs index 066fd2e..1bc75bc 100644 --- a/src/Language/Fiddle/Parser.hs +++ b/src/Language/Fiddle/Parser.hs @@ -254,7 +254,7 @@ registerBodyP = withMeta $ RegisterBody <$> bitBodyTypeP <*> defer body deferred deferredRegisterBodyP :: Pa DeferredRegisterBody deferredRegisterBodyP = - withMeta $ + withMetaLeaveComments $ DeferredRegisterBody <$> many (directedP registerBitsDeclP <* tok TokSemi) registerBitsDeclP :: Pa RegisterBitsDecl |