1 module Language.Symantic.Document.Sym where
4 import Data.Char (Char)
5 import Data.Eq (Eq(..))
6 import Data.Foldable (Foldable(..))
7 import Data.Function ((.), ($))
8 import Data.Functor (Functor(..))
9 import Data.Int (Int, Int64)
10 import Data.Ord (Ord(..), Ordering(..))
11 import Data.Semigroup (Semigroup(..))
12 import Data.String (String, IsString)
13 import Prelude (Integer, toInteger, fromIntegral, Num(..))
14 import qualified Data.List as List
15 import qualified Data.Text as Text
16 import qualified Data.Text.Lazy as TL
18 -- * Type family 'Column'
19 type family Column (d:: *) :: *
21 -- * Type family 'Indent'
22 type family Indent (d:: *) :: *
25 class (IsString d, Semigroup d) => Textable d where
26 charH :: Char -- ^ XXX: MUST NOT be '\n'
28 stringH :: String -- ^ XXX: MUST NOT contain '\n'
30 textH :: Text.Text -- ^ XXX: MUST NOT contain '\n'
32 ltextH :: TL.Text -- ^ XXX: MUST NOT contain '\n'
34 replicate :: Int -> d -> d
35 integer :: Integer -> d
36 default replicate :: Textable (ReprOf d) => Trans d => Int -> d -> d
37 default integer :: Textable (ReprOf d) => Trans d => Integer -> d
38 default charH :: Textable (ReprOf d) => Trans d => Char -> d
39 default stringH :: Textable (ReprOf d) => Trans d => String -> d
40 default textH :: Textable (ReprOf d) => Trans d => Text.Text -> d
41 default ltextH :: Textable (ReprOf d) => Trans d => TL.Text -> d
43 stringH = trans . stringH
45 ltextH = trans . ltextH
46 replicate = trans1 . replicate
47 integer = trans . integer
52 -- | @x '<+>' y = x '<>' 'space' '<>' y@
54 -- | @x '</>' y = x '<>' 'newline' '<>' y@
59 text :: Text.Text -> d
61 catH :: Foldable f => f d -> d
62 catV :: Foldable f => f d -> d
63 foldrWith :: Foldable f => (d -> d -> d) -> f d -> d
64 foldWith :: Foldable f => (d -> d) -> f d -> d
65 intercalate :: Foldable f => d -> f d -> d
66 between :: d -> d -> d -> d
70 x <+> y = x <> space <> y
71 x </> y = x <> newline <> y
72 int = integer . toInteger
73 char = \case '\n' -> newline; c -> charH c
74 string = catV . fmap stringH . lines
75 text = catV . fmap textH . Text.lines
76 ltext = catV . fmap ltextH . TL.lines
77 catH = foldr (<>) empty
78 catV = foldrWith (\x y -> x<>newline<>y)
79 foldrWith f ds = if null ds then empty else foldr1 f ds
80 foldWith f = foldrWith $ \a acc -> a <> f acc
81 intercalate sep = foldrWith (\x y -> x<>sep<>y)
82 between o c d = o<>d<>c
83 -- default catH :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
84 -- default catV :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
85 -- catH l = trans (catH (fmap unTrans l))
86 -- catV l = trans (catV (fmap unTrans l))
88 -- * Class 'Alignable'
89 class Textable d => Alignable d where
90 -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
92 -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
93 hang :: Indent d -> d -> d
94 hang ind = align . incrIndent ind
95 -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
96 incrIndent :: Indent d -> d -> d
97 -- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
98 withIndent :: Indent d -> d -> d
99 -- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.
101 -- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.
102 withNewline :: d -> d -> d
103 newlineWithoutIndent :: d
104 newlineWithIndent :: d
105 -- | @('column' f)@ return @f@ applied to the current 'Column'.
106 column :: (Column d -> d) -> d
107 -- | @('endToEndWidth' d f)@ return @d@ concatenated to
108 -- @f@ applied to the difference between the end 'Column' and start 'Column' of @d@.
110 -- Note that @f@ is given the end-to-end width,
111 -- which is not necessarily the maximal width.
112 default endToEndWidth ::
115 d -> (Column d -> d) -> d
116 endToEndWidth :: d -> (Column d -> d) -> d
117 endToEndWidth d f = column $ \c1 -> (d <>) $ column $ \c2 -> f $ c2 - c1
119 -- | @'spaces' ind = 'replicate' ind 'space'@
120 default spaces :: Indent d ~ Int => Indent d -> d
121 spaces :: Indent d -> d
122 spaces i = replicate i space
124 -- | @('fill' ind d)@ return @d@ then as many 'space's as needed
125 -- so that the whole is @ind@ 'Column's wide.
130 fill :: Indent d -> d -> d
132 endToEndWidth d $ \w ->
137 -- | @('breakableFill' ind f d)@ return @f@ then as many 'space's as needed
138 -- so that the whole is @ind@ 'Column's wide,
139 -- then, if @f@ is not wider than @ind@, appends @d@,
140 -- otherwise appends a 'newline' and @d@,
141 -- with an 'Indent' level set to the start 'Column' of @f@ plus @ind@.
142 default breakableFill ::
145 Indent d -> d -> d -> d
146 breakableFill :: Indent d -> d -> d -> d
147 breakableFill m f d =
149 endToEndWidth f $ \w ->
151 LT -> spaces (m - w) <> d
153 GT -> withIndent (c + m) (newline <> d)
155 -- * Class 'Wrapable'
156 class (Textable d, Alignable d) => Wrapable d where
157 -- | @('ifWrap' onWrap onNoWrap)@
158 -- return @onWrap@ if @onNoWrap@ leads to a 'Column'
159 -- greater or equal to the one sets with 'withWrapColumn',
160 -- otherwise return @onNoWrap@.
161 ifWrap :: d -> d -> d
162 -- | @('breakpoint' onNoBreak onBreak d)@
163 -- return @onNoBreak@ then @d@ if they fit,
164 -- @onBreak@ otherwise.
165 breakpoint :: d -> d -> d -> d
166 -- | @('breakableEmpty' d)@ return @d@ if it fits, 'newline' then @d@ otherwise.
167 breakableEmpty :: d -> d
168 breakableEmpty = breakpoint empty newline
169 -- | @x '><' y = x '<>' 'breakableEmpty' y@
171 x >< y = x <> breakableEmpty y
172 -- | @('breakableSpace' d)@ return 'space' then @d@ it they fit,
173 -- 'newline' then @d@ otherwise.
174 breakableSpace :: d -> d
175 breakableSpace = breakpoint space newline
176 -- | @x '>+<' y = x '<>' 'breakableSpace' y@
178 x >+< y = x <> breakableSpace y
179 -- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
180 -- between items of @ds@.
181 breakableSpaces :: Foldable f => f d -> d
182 breakableSpaces = foldWith breakableSpace
183 -- | @'withWrapColumn' col d@ set the 'Column' triggering wrapping to @col@ within @d@.
184 withWrapColumn :: Column d -> d -> d
185 -- | @('intercalateHorV' sep ds)@
186 -- return @ds@ with @sep@ intercalated if the whole fits,
187 -- otherwise return 'align' of @ds@ with 'newline' and @sep@ intercalated.
188 intercalateHorV :: Foldable f => d -> f d -> d
189 intercalateHorV sep xs =
191 (align $ foldWith ((newline <> sep) <>) xs)
192 (foldWith (sep <>) xs)
194 -- * Class 'Colorable'
195 class Colorable d where
196 -- | @('colorable' f)@ return @f@ applied to whether colors are activated or not.
197 colorable :: (Bool -> d) -> d
198 -- | @('withColor' b d)@ whether to active colors or not within @d@.
199 withColorable :: Bool -> d -> d
241 onMagentaer :: d -> d
245 default reverse :: Colorable (ReprOf d) => Trans d => d -> d
246 default black :: Colorable (ReprOf d) => Trans d => d -> d
247 default red :: Colorable (ReprOf d) => Trans d => d -> d
248 default green :: Colorable (ReprOf d) => Trans d => d -> d
249 default yellow :: Colorable (ReprOf d) => Trans d => d -> d
250 default blue :: Colorable (ReprOf d) => Trans d => d -> d
251 default magenta :: Colorable (ReprOf d) => Trans d => d -> d
252 default cyan :: Colorable (ReprOf d) => Trans d => d -> d
253 default white :: Colorable (ReprOf d) => Trans d => d -> d
254 default blacker :: Colorable (ReprOf d) => Trans d => d -> d
255 default redder :: Colorable (ReprOf d) => Trans d => d -> d
256 default greener :: Colorable (ReprOf d) => Trans d => d -> d
257 default yellower :: Colorable (ReprOf d) => Trans d => d -> d
258 default bluer :: Colorable (ReprOf d) => Trans d => d -> d
259 default magentaer :: Colorable (ReprOf d) => Trans d => d -> d
260 default cyaner :: Colorable (ReprOf d) => Trans d => d -> d
261 default whiter :: Colorable (ReprOf d) => Trans d => d -> d
262 default onBlack :: Colorable (ReprOf d) => Trans d => d -> d
263 default onRed :: Colorable (ReprOf d) => Trans d => d -> d
264 default onGreen :: Colorable (ReprOf d) => Trans d => d -> d
265 default onYellow :: Colorable (ReprOf d) => Trans d => d -> d
266 default onBlue :: Colorable (ReprOf d) => Trans d => d -> d
267 default onMagenta :: Colorable (ReprOf d) => Trans d => d -> d
268 default onCyan :: Colorable (ReprOf d) => Trans d => d -> d
269 default onWhite :: Colorable (ReprOf d) => Trans d => d -> d
270 default onBlacker :: Colorable (ReprOf d) => Trans d => d -> d
271 default onRedder :: Colorable (ReprOf d) => Trans d => d -> d
272 default onGreener :: Colorable (ReprOf d) => Trans d => d -> d
273 default onYellower :: Colorable (ReprOf d) => Trans d => d -> d
274 default onBluer :: Colorable (ReprOf d) => Trans d => d -> d
275 default onMagentaer :: Colorable (ReprOf d) => Trans d => d -> d
276 default onCyaner :: Colorable (ReprOf d) => Trans d => d -> d
277 default onWhiter :: Colorable (ReprOf d) => Trans d => d -> d
279 reverse = trans1 reverse
283 yellow = trans1 yellow
285 magenta = trans1 magenta
288 blacker = trans1 blacker
289 redder = trans1 redder
290 greener = trans1 greener
291 yellower = trans1 yellower
293 magentaer = trans1 magentaer
294 cyaner = trans1 cyaner
295 whiter = trans1 whiter
296 onBlack = trans1 onBlack
298 onGreen = trans1 onGreen
299 onYellow = trans1 onYellow
300 onBlue = trans1 onBlue
301 onMagenta = trans1 onMagenta
302 onCyan = trans1 onCyan
303 onWhite = trans1 onWhite
304 onBlacker = trans1 onBlacker
305 onRedder = trans1 onRedder
306 onGreener = trans1 onGreener
307 onYellower = trans1 onYellower
308 onBluer = trans1 onBluer
309 onMagentaer = trans1 onMagentaer
310 onCyaner = trans1 onCyaner
311 onWhiter = trans1 onWhiter
313 -- * Class 'Decorable'
314 class Decorable d where
315 -- | @('decorable' f)@ return @f@ applied to whether decorations are activated or not.
316 decorable :: (Bool -> d) -> d
317 -- | @('withColor' b d)@ whether to active decorations or not within @d@.
318 withDecorable :: Bool -> d -> d
323 default bold :: Decorable (ReprOf d) => Trans d => d -> d
324 default underline :: Decorable (ReprOf d) => Trans d => d -> d
325 default italic :: Decorable (ReprOf d) => Trans d => d -> d
327 underline = trans1 underline
328 italic = trans1 italic
332 -- | Return the underlying @tr@ of the transformer.
335 -- | Lift a tr to the transformer's.
336 trans :: ReprOf tr -> tr
337 -- | Unlift a tr from the transformer's.
338 unTrans :: tr -> ReprOf tr
340 -- | Identity transformation for a unary symantic method.
341 trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
342 trans1 f = trans . f . unTrans
344 -- | Identity transformation for a binary symantic method.
346 :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
348 trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
350 -- | Identity transformation for a ternary symantic method.
352 :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
353 -> (tr -> tr -> tr -> tr)
354 trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))
356 int64OfInt :: Int -> Int64
357 int64OfInt = fromIntegral
359 intOfInt64 :: Int64 -> Int
360 intOfInt64 = fromIntegral
362 -- | Break a 'String' into lines while preserving all empty lines.
363 lines :: String -> [String]
365 case List.break (== '\n') cs of
366 (chunk, _:rest) -> chunk : lines rest
367 (chunk, []) -> [chunk]