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.

1 files changed, 68 insertions, 166 deletions

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 <stdint.h>\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 ())