From c31a34382d6fe1307a0c6fe1710c42f27fe833ca Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 16 Oct 2024 00:03:09 -0600 Subject: Add framework for more easily editing files. This introduces the FilesM monad, which allows for monadic and fragmented writing to files in a filesystem. This provides an abstraction over writing to different "fragments" of files so implementation, headers and declarations can all be written using just one pass of the compiler. --- src/Language/Fiddle/Compiler/Backend/C.hs | 234 +++++++++--------------------- 1 file changed, 68 insertions(+), 166 deletions(-) (limited to 'src/Language/Fiddle/Compiler/Backend/C.hs') diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs index 9dbbec6..dd79bac 100644 --- a/src/Language/Fiddle/Compiler/Backend/C.hs +++ b/src/Language/Fiddle/Compiler/Backend/C.hs @@ -9,7 +9,7 @@ module Language.Fiddle.Compiler.Backend.C (cBackend) where import Control.Arrow import Control.Monad (unless) import Control.Monad.RWS -import Control.Monad.State (State) +import Control.Monad.State import Control.Monad.Trans.Writer (Writer, execWriter) import Data.Char (isSpace) import Data.Data (Typeable, cast) @@ -26,6 +26,9 @@ import Data.Text (Text) import qualified Data.Text as Text import Language.Fiddle.Ast import Language.Fiddle.Compiler.Backend +import qualified Language.Fiddle.Compiler.Backend.Internal.FragTree as FragTree +import Language.Fiddle.Compiler.Backend.Internal.FormattedWriter +import Language.Fiddle.Compiler.Backend.Internal.Writer import Language.Fiddle.Internal.UnitInterface import Language.Fiddle.Internal.UnitNumbers import Language.Fiddle.Types @@ -41,147 +44,47 @@ data CBackendFlags = CBackendFlags type StructName = Text -newtype Fragment = Fragment Int - deriving (Eq, Ord) - -- | Header fragment. The top. Starts which include guards and has include -- statements. -hF :: Fragment -hF = Fragment 0 +hF :: FileFragment +hF = ("HEADER", FragTree.above FragTree.center) -- | Structures fragment. The text fragment where structures are defined. -sF :: Fragment -sF = Fragment 25 +sF :: FileFragment +sF = ("HEADER", FragTree.below (snd hF)) -- | Implementation fragment. This is where function implementations go. -iF :: Fragment -iF = Fragment 75 +iF :: FileFragment +iF = ("HEADER", FragTree.above (snd fF)) -- | Assert fragment. This is where static asserts go. -aF :: Fragment -aF = Fragment 50 +aF :: FileFragment +aF = ("HEADER", FragTree.below (snd sF)) -- | 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" +fF :: FileFragment +fF = ("HEADER", FragTree.below FragTree.center) type A = Commented SourceSpan type I = Identity -data St = St - --- | Current local state information while traversing the tree. -data Fmt = Fmt - { indentLevel :: Int, - pendingLine :: Text - } - -newtype M a = M {unM :: RWS () () (St, Files) a} - deriving newtype (Functor, Applicative, Monad, MonadState (St, Files)) - -newtype FormattedWriter a = FormattedWriter (RWS () Text Fmt a) - deriving newtype (Functor, Applicative, Monad, MonadState Fmt) - -indented :: FileM a -> FileM a -indented fn = do - 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 () (Fmt 0 "") - -flush :: FormattedWriter () -flush = do - p <- gets pendingLine - modify $ \s -> s {pendingLine = ""} - tell p - -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 +type M a = FilesM () FormattedWriter CFileState a newtype CFileState = CFileState { includedFiles :: Set String } -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 :: String -> M () requireInclude file = do b <- (Set.member file) <$> gets includedFiles unless b $ do - under hF $ + checkout 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 (Just . (>> fn) . fromMaybe (return ())) fp fps - } - ) - -instance MonadWriter Text FormattedWriter where - tell txt = FormattedWriter $ do - indent <- (`Text.replicate` " ") <$> gets indentLevel - let lines = Text.splitOn "\n" txt - forM_ (init lines) $ \line -> do - pending <- gets pendingLine - modify $ \s -> s {pendingLine = ""} - tell indent - tell pending - tell line - tell "\n" - modify $ \s -> s {pendingLine = pendingLine s <> last lines} - - listen (FormattedWriter fn) = FormattedWriter $ listen fn - - pass (FormattedWriter fn) = FormattedWriter $ pass fn - cBackend :: Backend cBackend = Backend @@ -211,10 +114,6 @@ cBackend = backendTranspile = transpile } -toTranspileResult :: Files -> TranspileResult -toTranspileResult Files {filepaths = fps} = - TranspileResult $ fmap execFileM fps - transpile :: CBackendFlags -> () -> @@ -226,28 +125,37 @@ transpile cSourceOut = sourceFile } () - fiddleUnit = toTranspileResult . snd . fst $ execRWS (unM run) () (St, Files mempty) + fiddleUnit = toTranspileResult $ fst $ runFilesM execFormattedWriter () (CFileState mempty) hF run where - run :: M () + toTranspileResult :: Map FilePath Text -> TranspileResult + toTranspileResult mp = + TranspileResult $ + Map.mapKeys + ( \case + "SOURCE" | Right sourceFile' <- sourceFile -> sourceFile' + "HEADER" -> headerFile + k -> k + ) + mp + run = do - withFile headerFile $ do + checkout hF $ textM $ do tell $ "#ifndef " <> headerGuard <> "\n" tell $ "#define " <> headerGuard <> "\n\n" tell "#include \n" - -- Pad out the implementation - under iF $ text "\n" + -- Pad out the implementation + checkout iF $ text "\n" walk (transpileWalk sourceFile headerFile) fiddleUnit () - withFile headerFile $ do - under hF $ - textM $ do - tell "\nstatic_assert(true); // https://github.com/clangd/clangd/issues/1167\n" + checkout hF $ + textM $ do + tell "\nstatic_assert(true); // https://github.com/clangd/clangd/issues/1167\n" - under fF $ - text headerFinal + checkout fF $ + text headerFinal headerFinal = "\n#endif /* " <> headerGuard <> " */\n" @@ -269,20 +177,10 @@ instance IsText Text where qualifiedPathToIdentifier :: (Foldable f, IsText t) => f t -> Text qualifiedPathToIdentifier = Text.intercalate "_" . map toText . toList -ensureNL :: FormattedWriter () -ensureNL = do - p <- gets pendingLine - if Text.null p - then return () - else do - modify $ \s -> s {pendingLine = ""} - tell p - tell "\n" - -pad :: FileM () -> FileM () +pad :: M () -> M () pad f = text "\n" *> f <* text "\n" -writeStaticAssert :: Text -> String -> N Bytes -> FileM () +writeStaticAssert :: Text -> String -> N Bytes -> M () writeStaticAssert structName regname off = do requireInclude "stddef.h" text $ @@ -309,7 +207,7 @@ selectByModifier mod (getter, setter) = (ModifierKeyword Wo _) -> [setter] (ModifierKeyword Pr _) -> [] -writeRegGet :: StructName -> QRegMetadata True -> FileM () +writeRegGet :: StructName -> QRegMetadata True -> M () writeRegGet structType ( QRegMetadata @@ -347,7 +245,7 @@ writeRegGet tell $ Text.pack $ printf " out[%d] = o->%s[%d];\n" i fieldName i tell "}\n\n" -writeRegSet :: StructName -> QRegMetadata True -> FileM () +writeRegSet :: StructName -> QRegMetadata True -> M () writeRegSet structType ( QRegMetadata @@ -401,10 +299,10 @@ pattern DefinedBitsP bitsName bitsFullPath offset <- } ) -writeRegisterBody :: StructName -> QRegMetadata True -> RegisterBody Checked I A -> FileM () +writeRegisterBody :: StructName -> QRegMetadata True -> RegisterBody Checked I A -> M () writeRegisterBody structName regmeta = walk_ registerWalk where - registerWalk :: forall t. (Walk t, Typeable t) => t I A -> FileM () + registerWalk :: forall t. (Walk t, Typeable t) => t I A -> M () registerWalk t = case () of () | (Just (DefinedBitsP bitsName fullPath offset)) <- castTS t -> @@ -433,7 +331,7 @@ writeImplementation :: QRegMetadata True -> Modifier f a -> Maybe (RegisterBody Checked I A) -> - FileM () + M () -- | Register is just padding, don't emit anything writeImplementation _ (regIsPadding -> True) _ _ = return () @@ -444,7 +342,7 @@ writeImplementation structName qMeta mod bod = do mapM_ (writeRegisterBody structName qMeta) bod -structBody :: StructName -> ObjTypeBody Checked I A -> FileM () +structBody :: StructName -> ObjTypeBody Checked I A -> M () structBody structName (ObjTypeBody _ decls _) = do forM_ decls $ \(Directed _ decl _) -> case decl of @@ -462,10 +360,10 @@ structBody structName (ObjTypeBody _ decls _) = do tell (sizeToField i sz) tell ";\n" - under aF $ + checkout aF $ writeStaticAssert structName i off - under iF $ + checkout iF $ writeImplementation structName regMetadata mod bod TypeSubStructure { subStructureBody = Identity bod, @@ -491,7 +389,7 @@ structBody structName (ObjTypeBody _ decls _) = do 8 -> "volatile uint64_t " <> f n -> "volatile uint8_t " <> f <> "[" <> Text.pack (show n) <> "]" -union :: Text -> FileM () -> FileM () +union :: Text -> M () -> M () union identifier fn = do text "#pragma pack(push, 1)\n" text $ "union " <> identifier <> " " @@ -499,7 +397,7 @@ union identifier fn = do text ";\n" text "#pragma pack(pop)\n" -struct :: Text -> FileM () -> FileM () +struct :: Text -> M () -> M () struct identifier fn = do text "#pragma pack(push, 1)\n" text $ "struct " <> identifier <> " " @@ -507,8 +405,11 @@ struct identifier fn = do text ";\n" text "#pragma pack(pop)\n" -body :: FileM a -> FileM a -body f = text "{\n" *> indented f <* textM (ensureNL >> tell "}") +body :: M a -> M a +body f = text "{\n" *> withIndent f <* textM (ensureNL >> tell "}") + +withIndent :: M a -> M a +withIndent = block incIndent decIndent identifierFor :: (ExportableDecl d) => d -> Text identifierFor = qualifiedPathToIdentifier . metadataFullyQualifiedPath . getMetadata @@ -536,7 +437,10 @@ emitDocComments (Commented comments _) = do then Text.tail t else t -transpileWalk :: Either ImplementationInHeader FilePath -> FilePath -> (forall t. (Walk t, Typeable t) => t I A -> () -> M (WalkContinuation ())) +transpileWalk :: + Either ImplementationInHeader FilePath -> + FilePath -> + (forall t. (Walk t, Typeable t) => t I A -> () -> M (WalkContinuation ())) transpileWalk _ headerFile t _ = case () of () | Just @@ -551,21 +455,19 @@ transpileWalk _ headerFile t _ = case () of Union {} -> union Struct {} -> struct - withFile headerFile $ do - under sF $ do - pad $ do - textM $ emitDocComments a - let structName = identifierFor (unwrap metadata) - structureType structName $ do - structBody structName objTypeBody + checkout 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) + checkout fF $ do + text "#define " + text qname + text $ Text.pack $ printf " ((%s*)0x%08x)\n" (toLiteralTypeName (exportedObjectDeclType e)) (exportedObjectDeclLocation e) return Stop _ -> return (Continue ()) -- cgit