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. --- .../Fiddle/Compiler/Backend/Internal/Writer.hs | 149 +++++++++++++++++++++ 1 file changed, 149 insertions(+) create mode 100644 src/Language/Fiddle/Compiler/Backend/Internal/Writer.hs (limited to 'src/Language/Fiddle/Compiler/Backend/Internal/Writer.hs') 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 -- cgit