1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
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
|
