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.

3 files changed, 421 insertions, 0 deletions

diff --git a/src/Language/Fiddle/Compiler/Backend/Internal/FormattedWriter.hs b/src/Language/Fiddle/Compiler/Backend/Internal/FormattedWriter.hs
new file mode 100644
index 0000000..bde9ebe
--- /dev/null
+++ b/src/Language/Fiddle/Compiler/Backend/Internal/FormattedWriter.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# 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. 
+-- 
+-- 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.
+    -- * 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'.
+  )
+where
+
+import Control.Monad (forM_)
+import Control.Monad.RWS.Strict
+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.
+  }
+
+-- | The 'FormattedWriter' is a monad that provides functionality for writing
+-- formatted text, with control over indentation and newlines.
+newtype FormattedWriter a = FormattedWriter (RWS () Text Fmt a)
+  deriving newtype (Functor, Applicative, Monad, MonadState Fmt)
+
+-- | 'MonadWriter' instance for 'FormattedWriter', which allows writing text
+-- while maintaining proper indentation and ensuring that newlines are handled
+-- correctly. Each line is prefixed with the correct indentation level.
+instance MonadWriter Text FormattedWriter where
+  tell txt = FormattedWriter $ do
+    -- Get the current indentation level and prepare the indentation prefix.
+    indent <- (`Text.replicate` "  ") <$> gets indentLevel
+    -- Split the text into lines.
+    let lines = Text.splitOn "\n" txt
+    -- 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
+      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.
+    modify $ \s -> s {pendingLine = pendingLine s <> Prelude.last lines}
+
+  -- Allow listening to the written text within the 'FormattedWriter' context.
+  listen (FormattedWriter fn) = FormattedWriter $ listen fn
+
+  -- Allow transformation of the written text via a pass operation.
+  pass (FormattedWriter fn) = FormattedWriter $ pass fn
+
+-- | Ensures that a newline is written if there is any pending text. This is
+-- useful for ensuring that the output ends on a clean line.
+ensureNL :: FormattedWriter ()
+ensureNL = do
+  p <- gets pendingLine
+  if Text.null p
+    then return ()
+    else do
+      modify $ \s -> s {pendingLine = ""}
+      tell p
+      tell "\n"
+
+-- | Flushes the pending line by writing it to the output and clearing the
+-- pending state. This is useful when you want to force the current line to
+-- be written immediately.
+flush :: FormattedWriter ()
+flush = do
+  p <- gets pendingLine
+  modify $ \s -> s {pendingLine = ""}
+  tell p
+
+-- | 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)
+
+-- | 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)
+
+-- | 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
+
+-- | 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.
+
diff --git a/src/Language/Fiddle/Compiler/Backend/Internal/FragTree.hs b/src/Language/Fiddle/Compiler/Backend/Internal/FragTree.hs
new file mode 100644
index 0000000..bc55c5a
--- /dev/null
+++ b/src/Language/Fiddle/Compiler/Backend/Internal/FragTree.hs
@@ -0,0 +1,159 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+
+-- | Module for a 'FragTree' data structure. This data structure represents
+-- "fragments" of a file, which are logical points in a file or buffer.
+--
+-- A fragment represents an indexed position in a file, but the position
+-- is not necessarily discrete. Instead, fragments can be positioned
+-- relative to each other (e.g., above or below other fragments),
+-- allowing for arbitrary resolution within the file.
+module Language.Fiddle.Compiler.Backend.Internal.FragTree
+  ( -- * Types
+    Fragment,
+    FragTree,
+
+    -- * Fragment Constructors
+    center,
+    -- | A fragment at the center of the file.
+    above,
+    -- | A fragment above a given fragment.
+    below,
+    -- | A fragment below a given fragment.
+    -- * FragTree Operations
+    updateWithReturn,
+    -- | Update a fragment in the tree and return a custom value.
+    Language.Fiddle.Compiler.Backend.Internal.FragTree.lookup,
+    -- | Lookup a value by fragment.
+    update,
+    -- | Update or insert a value into the tree.
+    insertOrReplace,
+    -- | Insert a value at a fragment, replacing any existing value.
+    insertAppend,
+    -- | Insert a value by appending (using 'Monoid') if a value already exists.
+    insertWith,
+    -- | Insert a value, combining it with an existing value using a custom function.
+    delete,
+    -- | Delete a value from the tree at a specific fragment.
+    singleton,
+    -- | Create a tree with a single fragment and value.
+  )
+where
+
+-- | Direction of a fragment relative to another fragment.
+data Loc = Above | Below
+
+-- | A 'Fragment' is a position in a file or buffer that can be relative
+-- to other fragments (above or below).
+newtype Fragment = Fragment [Loc]
+
+-- | Fragment that represents the center of the file.
+center :: Fragment
+center = Fragment []
+
+-- | Create a fragment above the given fragment.
+above :: Fragment -> Fragment
+above (Fragment l) = Fragment $ Above : l
+
+-- | Create a fragment below the given fragment.
+below :: Fragment -> Fragment
+below (Fragment l) = Fragment $ Below : l
+
+-- | A 'FragTree' represents a binary tree where each node holds a fragment's value.
+-- Each tree node has two children, representing the fragments above and below
+-- the current fragment. Leaves represent empty nodes.
+data FragTree a
+  = FragTree (FragTree a) (FragTree a) (Maybe a)
+  | FragLeaf
+  deriving (Functor)
+
+instance Foldable FragTree where
+  foldMap _ FragLeaf = mempty
+  foldMap fn (FragTree up down t) =
+    foldMap fn up <> foldMap fn t <> foldMap fn down
+
+instance Traversable FragTree where
+  traverse _ FragLeaf = pure FragLeaf
+  traverse fn (FragTree up down t) = do
+    (\a b c -> FragTree a c b)
+      <$> traverse fn up
+      <*> traverse fn t
+      <*> traverse fn down
+
+-- | 'Semigroup' instance for 'FragTree', merging two trees by combining values
+-- from corresponding fragments, using the 'Semigroup' instance of the contained values.
+instance (Semigroup a) => Semigroup (FragTree a) where
+  (<>) (FragTree ab1 be1 v1) (FragTree ab2 be2 v2) =
+    FragTree (ab1 <> ab2) (be1 <> be2) (v1 <> v2)
+  (<>) FragLeaf f = f
+  (<>) f FragLeaf = f
+
+-- | 'Monoid' instance for 'FragTree'. The empty tree is represented by 'FragLeaf'.
+instance (Semigroup a) => Monoid (FragTree a) where
+  mempty = FragLeaf
+
+-- | 'updateWithReturn' updates a 'FragTree' at the specified 'Fragment',
+-- returning both a custom value and the updated tree.
+-- If the fragment doesn't exist, it is created.
+updateWithReturn :: (Maybe a -> (b, Maybe a)) -> Fragment -> FragTree a -> (b, FragTree a)
+updateWithReturn fn (Fragment (reverse -> loc)) = update' fn loc
+  where
+    -- Helper function for traversing and updating the tree.
+    update' fn [] FragLeaf = clean . FragTree FragLeaf FragLeaf <$> fn Nothing
+    update' fn [] (FragTree a b v) = clean . FragTree a b <$> fn v
+    update' fn (Above : ls) (FragTree a b v) =
+      fmap clean $
+        (\a' -> FragTree a' b v) <$> update' fn ls a
+    update' fn (Below : ls) (FragTree a b v) =
+      fmap clean $
+        (\b' -> FragTree a b' v) <$> update' fn ls b
+    update' fn (Above : ls) FragLeaf =
+      fmap clean $
+        (\a' -> FragTree a' FragLeaf Nothing) <$> update' fn ls FragLeaf
+    update' fn (Below : ls) FragLeaf =
+      fmap clean $
+        (\b' -> FragTree FragLeaf b' Nothing) <$> update' fn ls FragLeaf
+
+-- | Create a 'FragTree' with a single 'Fragment' and associated value.
+singleton :: Fragment -> a -> FragTree a
+singleton f a = insertOrReplace f a FragLeaf
+
+-- | Lookup a value in the 'FragTree' by its 'Fragment'. Returns 'Nothing'
+-- if the fragment does not exist.
+lookup :: Fragment -> FragTree a -> Maybe a
+lookup l = fst . updateWithReturn (\a -> (a, a)) l
+
+-- | Update a 'FragTree' at the given 'Fragment'. If the fragment does not exist,
+-- it is created. The function is applied to the existing value (or 'Nothing' if no value).
+update :: (Maybe a -> Maybe a) -> Fragment -> FragTree a -> FragTree a
+update fn fr = snd . updateWithReturn (\ma -> ((), fn ma)) fr
+
+-- | Insert a value into the 'FragTree', replacing any existing value at the given fragment.
+insertOrReplace :: Fragment -> a -> FragTree a -> FragTree a
+insertOrReplace l a = update (const $ Just a) l
+
+-- | Delete a fragment from the 'FragTree', setting its value to 'Nothing'.
+delete :: Fragment -> FragTree a -> FragTree a
+delete = update (const Nothing)
+
+-- | Insert a value by appending (using the 'Monoid' instance) to an existing value
+-- at the given fragment. If no value exists, the provided value is inserted.
+insertAppend :: (Monoid a) => Fragment -> a -> FragTree a -> FragTree a
+insertAppend l a = update (<> Just a) l
+
+-- | Insert a value using a custom function to combine it with an existing value
+-- at the given fragment. If no val
+insertWith :: (a -> a -> a) -> Fragment -> a -> FragTree a -> FragTree a
+insertWith fn fr v =
+  update
+    ( \case
+        Nothing -> Just v
+        Just a -> Just (fn a v)
+    )
+    fr
+
+-- | Internal function for cleaning up a 'FragTree' by collapsing empty nodes
+-- (i.e., 'FragTree' nodes with no values and no children) into 'FragLeaf'.
+clean :: FragTree a -> FragTree a
+clean (FragTree FragLeaf FragLeaf Nothing) = FragLeaf
+clean x = x
diff --git a/src/Language/Fiddle/Compiler/Backend/Internal/Writer.hs b/src/Language/Fiddle/Compiler/Backend/Internal/Writer.hs
new file mode 100644
index 0000000..83f6e27
--- /dev/null
+++ b/src/Language/Fiddle/Compiler/Backend/Internal/Writer.hs
@@ -0,0 +1,149 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module contains the 'FilesM' monad, which allows for incremental,
+-- fragmented, and monadic editing of "files" in a "filesystem" (represented as a
+-- 'Map' from 'FilePath' to 'Text').
+--
+-- The 'FilesM' monad provides operations for "checking out" file fragments, writing
+-- text to them, and managing file modifications in a monadic fashion.
+-- The final result, produced by 'runFilesM', is a map of file paths to text,
+-- representing the contents that should be written to each file.
+module Language.Fiddle.Compiler.Backend.Internal.Writer
+  ( -- * Types
+    FileFragment,
+
+    -- * FilesM Operations
+
+    -- | Run the 'FilesM' monad and produce the final map of files and their contents.
+    runFilesM,
+    -- | A variant of 'runFilesM' that runs with a 'Writer'.
+    runFileMWriter,
+    -- | Write plain text to the current file fragment.
+    text,
+    -- | Write a monadic action that produces text to the current file fragment.
+    textM,
+    -- | The 'FilesM' monad for file-based operations.
+    FilesM,
+    -- | Checkout a specific file fragment for writing.
+    checkout,
+    -- | Write a line of text (with a newline) to the current file fragment.
+    tellLn,
+    -- | Surround a block of file operations with a start and end marker.
+    block,
+  )
+where
+
+import Control.Arrow
+import Control.Monad.RWS.Strict
+import Control.Monad.Trans.Writer (Writer, execWriter)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Monoid
+import Data.Text (Text)
+import Language.Fiddle.Compiler.Backend.Internal.FragTree (FragTree, Fragment)
+import qualified Language.Fiddle.Compiler.Backend.Internal.FragTree as FragTree
+
+-- | 'FileMap' represents the mapping between 'FilePath' and file content.
+-- The content of each file is stored as a 'FragTree', which can hold fragments
+-- of text.
+newtype FileMap a = FileMap (Map FilePath a)
+  deriving newtype (Functor, Show, Foldable)
+
+-- | 'Semigroup' instance for 'FileMap'. When merging two 'FileMap's, the content
+-- of each file is combined using the 'Semigroup' instance of the file content type.
+instance (Semigroup a) => Semigroup (FileMap a) where
+  (<>) (FileMap m1) (FileMap m2) = FileMap $ Map.unionWith (<>) m1 m2
+
+-- | 'Monoid' instance for 'FileMap'. The empty file map is represented by an empty map.
+instance (Semigroup a) => Monoid (FileMap a) where
+  mempty = FileMap mempty
+
+-- | The 'FilesM' monad provides a context for managing file fragments and writing
+-- content to them in a monadic style. It is parameterized over:
+--
+-- * @r@: The environment shared across file writes (e.g., metadata or global settings).
+-- * @w@: The writer monad used to accumulate file content ('Text' or some other type).
+-- * @s@: The state type for managing any local state during the file writes.
+-- * @a@: The return type of the computation.
+newtype FilesM r w s a
+  = FilesM
+      ( RWS
+          (r, FileFragment) -- Reader context containing global settings and current file fragment.
+          (FileMap (FragTree (Ap w ()))) -- Writer accumulating the file content as a 'FragTree'.
+          (s, w ()) -- State holding user-provided state 's' and the current writer accumulator.
+          a -- Result of the computation.
+      )
+  deriving newtype (Functor, Applicative, Monad)
+
+-- | 'MonadState' instance for 'FilesM'. Allows manipulation of state within the 'FilesM' monad.
+instance (Applicative w) => MonadState s (FilesM r w s) where
+  get = FilesM $ fst <$> get
+  put v = FilesM $ modify $ first (const v)
+
+-- | 'MonadReader' instance for 'FilesM'. Allows access to reader environment.
+instance (Applicative w) => MonadReader r (FilesM r w s) where
+  ask = FilesM $ fst <$> ask
+  local fn (FilesM a) = FilesM $ local (first fn) a
+
+-- | A 'FileFragment' represents a specific section of a file. It is a tuple of a 'FilePath'
+-- and a 'Fragment', which denotes a position in the file where modifications are made.
+type FileFragment = (FilePath, Fragment)
+
+-- | Checkout a specific file fragment for writing. After checking out a fragment,
+-- subsequent file operations will affect that fragment until another fragment is checked out.
+checkout :: (Monad w) => FileFragment -> FilesM r w s a -> FilesM r w s a
+checkout (fileName, newFrag) (FilesM fn) =
+  FilesM $ do
+    flush -- Flush any existing writes before switching fragments
+    -- Change the current fragment being worked on
+    local (\(r, _) -> (r, (fileName, newFrag))) $ fn <* flush
+  where
+    (FilesM flush) = flushFilesM
+
+-- | Internal helper function that flushes the current state of the 'FilesM' monad
+-- by committing any pending writes to the current file fragment.
+flushFilesM :: (Monad w) => FilesM r w s ()
+flushFilesM = FilesM $ do
+  (fileName, frag) <- asks snd -- Get the current file and fragment being written to
+  writer <- gets snd -- Get the current text to write
+  modify $ \(s, _) -> (s, return ()) -- Clear the writer
+  tell $ FileMap $ Map.singleton fileName $ FragTree.singleton frag (Ap writer)
+
+-- | Write plain text to the current file fragment.
+text :: (MonadWriter t w) => t -> FilesM r w s ()
+text txt = FilesM $ modify (second (>> tell txt))
+
+-- | Write a monadic action that produces text to the current file fragment.
+textM :: (Monad w) => w () -> FilesM r w s ()
+textM fn = FilesM $ modify (second (>> fn))
+
+-- | Run the 'FilesM' monad and produce the final file map along with any additional state.
+-- The result is a 'Map' from 'FilePath' to some textual representation, as well as
+-- the final state of the monad.
+runFilesM ::
+  (Monad w) =>
+  (forall x. w x -> t) -> -- Function to extract text from the writer monad
+  r -> -- Reader environment
+  s -> -- Initial state
+  FileFragment -> -- Initial file fragment to write to
+  FilesM r w s a -> -- FilesM monadic action to run
+  (Map FilePath t, (a, s)) -- Final map of files and their contents, and final result and state
+runFilesM exec rr ss initFrag ((<* flushFilesM) -> FilesM rws) =
+  let (a, (s, _), FileMap filesMap) = runRWS rws (rr, initFrag) (ss, return ())
+   in (fmap (exec . mapM_ getAp) filesMap, (a, s))
+
+-- | A helper function to run 'FilesM' with a 'Writer' monad, where each file's contents
+-- is represented as a monoid (such as 'Text').
+runFileMWriter :: (Monoid t) => r -> s -> FileFragment -> FilesM r (Writer t) s a -> Map FilePath t
+runFileMWriter r s initFrag f = fst $ runFilesM execWriter r s initFrag f
+
+-- | Write a line of text (appends a newline) to the current file fragment.
+tellLn :: (MonadWriter Text m) => Text -> m ()
+tellLn s = tell s >> tell "\n"
+
+-- | Surround a block of file operations with a start and end marker.
+-- This is useful for inserting things like function or block delimiters.
+block :: (Monad w) => w () -> w () -> FilesM r w s a -> FilesM r w s a
+block s e f = textM s *> f <* textM e