diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/Backend/Internal')
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 |