1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 module Language.Symantic.Document.Sym where
5 import Data.Char (Char)
6 import Data.Eq (Eq(..))
7 import Data.Foldable (Foldable(..))
8 import Data.Function ((.), ($))
9 import Data.Functor (Functor(..))
11 import Data.Maybe (Maybe(..))
12 import Data.Ord (Ord(..), Ordering(..))
13 import Data.Semigroup (Semigroup(..))
14 import Data.String (String, IsString)
15 import Prelude (Integer, fromIntegral, Num(..), pred, undefined, Integral, Real, Enum)
16 import Text.Show (Show(..))
17 import qualified Data.List as List
18 import qualified Data.Text as Text
19 import qualified Data.Text.Lazy as TL
22 newtype Nat = Nat Integer
23 deriving (Eq, Ord, Show, Integral, Real, Enum)
24 unLength :: Nat -> Integer
26 instance Num Nat where
27 fromInteger i | 0 <= i = Nat i
28 | otherwise = undefined
29 abs = Nat . abs . unLength
30 signum = signum . signum
31 Nat x + Nat y = Nat (x + y)
32 Nat x * Nat y = Nat (x * y)
33 Nat x - Nat y | y <= x = Nat (x - y)
34 | otherwise = undefined
36 -- * Class 'Lengthable'
37 class Lengthable a where
39 instance Lengthable Char where
41 instance Lengthable [a] where
42 length = Nat . fromIntegral . List.length
43 instance Lengthable Text.Text where
44 length = Nat . fromIntegral . Text.length
45 instance Lengthable TL.Text where
46 length = Nat . fromIntegral . TL.length
55 class (IsString d, Semigroup d) => Textable d where
57 charH :: Char -- ^ XXX: MUST NOT be '\n'
59 stringH :: String -- ^ XXX: MUST NOT contain '\n'
61 textH :: Text.Text -- ^ XXX: MUST NOT contain '\n'
63 ltextH :: TL.Text -- ^ XXX: MUST NOT contain '\n'
65 default empty :: Textable (ReprOf d) => Trans d => d
66 default charH :: Textable (ReprOf d) => Trans d => Char -> d
67 default stringH :: Textable (ReprOf d) => Trans d => String -> d
68 default textH :: Textable (ReprOf d) => Trans d => Text.Text -> d
69 default ltextH :: Textable (ReprOf d) => Trans d => TL.Text -> d
72 stringH = trans . stringH
74 ltextH = trans . ltextH
78 -- | @x '<+>' y = x '<>' 'space' '<>' y@
80 -- | @x '</>' y = x '<>' 'newline' '<>' y@
83 integer :: Integer -> d
86 text :: Text.Text -> d
88 catH :: Foldable f => f d -> d
89 catV :: Foldable f => f d -> d
90 unwords :: Foldable f => f d -> d
91 unlines :: Foldable f => f d -> d
92 foldrWith :: Foldable f => (d -> d -> d) -> f d -> d
93 foldWith :: Foldable f => (d -> d) -> f d -> d
94 intercalate :: Foldable f => d -> f d -> d
95 between :: d -> d -> d -> d
96 replicate :: Int -> d -> d
100 x <+> y = x <> space <> y
101 x </> y = x <> newline <> y
103 integer = stringH . show
104 char = \case '\n' -> newline; c -> charH c
105 string = catV . fmap stringH . lines
106 text = catV . fmap textH . Text.lines
107 ltext = catV . fmap ltextH . TL.lines
108 catH = foldr (<>) empty
109 catV = foldrWith (\x y -> x<>newline<>y)
110 unwords = foldr (<>) space
111 unlines = foldr (\x y -> x<>newline<>y) empty
112 foldrWith f ds = if null ds then empty else foldr1 f ds
113 foldWith f = foldrWith $ \a acc -> a <> f acc
114 intercalate sep = foldrWith (\x y -> x<>sep<>y)
115 between o c d = o<>d<>c
116 replicate cnt t | cnt <= 0 = empty
117 | otherwise = t <> replicate (pred cnt) t
119 -- * Class 'Indentable'
120 class Textable d => Indentable d where
121 -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
123 -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
124 incrIndent :: Indent -> d -> d
125 -- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
126 withIndent :: Indent -> d -> d
127 -- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.
129 -- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.
130 withNewline :: d -> d -> d
131 newlineWithoutIndent :: d
132 newlineWithIndent :: d
133 -- | @('column' f)@ write @f@ applied to the current 'Column'.
134 column :: (Column -> d) -> d
135 -- | @('indent' f)@ write @f@ applied to the current 'Indent'.
136 indent :: (Indent -> d) -> d
138 -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
139 hang :: Indent -> d -> d
140 hang ind = align . incrIndent ind
142 -- | @('endToEndWidth' d f)@ write @d@ then
143 -- @f@ applied to the difference between
144 -- the end 'Column' and start 'Column' of @d@.
146 -- Note that @f@ is given the end-to-end width,
147 -- which is not necessarily the maximal width.
148 endToEndWidth :: d -> (Column -> d) -> d
149 endToEndWidth d f = column $ \c1 -> (d <>) $ column $ \c2 -> f $ c2 - c1
151 -- | @'spaces' ind = 'replicate' ind 'space'@
152 spaces :: Indent -> d
153 spaces i = replicate (fromIntegral i) space
155 -- | @('fill' ind d)@ write @d@,
156 -- then if @d@ is not wider than @ind@,
157 -- write the difference with 'spaces'.
158 fill :: Indent -> d -> d
160 endToEndWidth d $ \w ->
165 -- | @('breakableFill' ind d)@ write @d@,
166 -- then if @d@ is not wider than @ind@, write the difference with 'spaces'
167 -- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @ind@.
168 breakableFill :: Indent -> d -> d
171 endToEndWidth d $ \w ->
173 LT -> spaces (m - w) <> empty
175 GT -> withIndent (c + m) newline
177 -- * Class 'Breakable'
178 class (Textable d, Indentable d) => Breakable d where
179 -- | @('breakable' f)@ write @f@ applied to whether breaks are activated or not.
180 breakable :: (Maybe Column -> d) -> d
181 -- | @('withBreakable' b d)@ whether to active breaks or not within @d@.
182 withBreakable :: Maybe Column -> d -> d
183 -- | @('ifBreak' onWrap onNoWrap)@
184 -- write @onWrap@ if @onNoWrap@ leads to a 'Column'
185 -- greater or equal to the one sets with 'withBreakable',
186 -- otherwise write @onNoWrap@.
187 ifBreak :: d -> d -> d
188 -- | @('breakpoint' onNoBreak onBreak d)@
189 -- write @onNoBreak@ then @d@ if they fit,
190 -- @onBreak@ otherwise.
191 breakpoint :: d -> d -> d -> d
193 -- | @('breakableEmpty' d)@ write @d@ if it fits, 'newline' then @d@ otherwise.
194 breakableEmpty :: d -> d
195 breakableEmpty = breakpoint empty newline
197 -- | @x '><' y = x '<>' 'breakableEmpty' y@
199 x >< y = x <> breakableEmpty y
201 -- | @('breakableSpace' d)@ write 'space' then @d@ it they fit,
202 -- 'newline' then @d@ otherwise.
203 breakableSpace :: d -> d
204 breakableSpace = breakpoint space newline
206 -- | @x '>+<' y = x '<>' 'breakableSpace' y@
208 x >+< y = x <> breakableSpace y
210 -- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
211 -- between items of @ds@.
212 breakableSpaces :: Foldable f => f d -> d
213 breakableSpaces = foldWith breakableSpace
215 -- | @('intercalateHorV' sep ds)@
216 -- write @ds@ with @sep@ intercalated if the whole fits,
217 -- otherwise write 'align' of @ds@ with 'newline' and @sep@ intercalated.
218 intercalateHorV :: Foldable f => d -> f d -> d
219 intercalateHorV sep xs =
221 (align $ foldWith ((newline <> sep) <>) xs)
222 (foldWith (sep <>) xs)
224 -- * Class 'Colorable'
225 class Colorable d where
226 -- | @('colorable' f)@ write @f@ applied to whether colors are activated or not.
227 colorable :: (Bool -> d) -> d
228 -- | @('withColor' b d)@ whether to active colors or not within @d@.
229 withColorable :: Bool -> d -> d
271 onMagentaer :: d -> d
275 default reverse :: Colorable (ReprOf d) => Trans d => d -> d
276 default black :: Colorable (ReprOf d) => Trans d => d -> d
277 default red :: Colorable (ReprOf d) => Trans d => d -> d
278 default green :: Colorable (ReprOf d) => Trans d => d -> d
279 default yellow :: Colorable (ReprOf d) => Trans d => d -> d
280 default blue :: Colorable (ReprOf d) => Trans d => d -> d
281 default magenta :: Colorable (ReprOf d) => Trans d => d -> d
282 default cyan :: Colorable (ReprOf d) => Trans d => d -> d
283 default white :: Colorable (ReprOf d) => Trans d => d -> d
284 default blacker :: Colorable (ReprOf d) => Trans d => d -> d
285 default redder :: Colorable (ReprOf d) => Trans d => d -> d
286 default greener :: Colorable (ReprOf d) => Trans d => d -> d
287 default yellower :: Colorable (ReprOf d) => Trans d => d -> d
288 default bluer :: Colorable (ReprOf d) => Trans d => d -> d
289 default magentaer :: Colorable (ReprOf d) => Trans d => d -> d
290 default cyaner :: Colorable (ReprOf d) => Trans d => d -> d
291 default whiter :: Colorable (ReprOf d) => Trans d => d -> d
292 default onBlack :: Colorable (ReprOf d) => Trans d => d -> d
293 default onRed :: Colorable (ReprOf d) => Trans d => d -> d
294 default onGreen :: Colorable (ReprOf d) => Trans d => d -> d
295 default onYellow :: Colorable (ReprOf d) => Trans d => d -> d
296 default onBlue :: Colorable (ReprOf d) => Trans d => d -> d
297 default onMagenta :: Colorable (ReprOf d) => Trans d => d -> d
298 default onCyan :: Colorable (ReprOf d) => Trans d => d -> d
299 default onWhite :: Colorable (ReprOf d) => Trans d => d -> d
300 default onBlacker :: Colorable (ReprOf d) => Trans d => d -> d
301 default onRedder :: Colorable (ReprOf d) => Trans d => d -> d
302 default onGreener :: Colorable (ReprOf d) => Trans d => d -> d
303 default onYellower :: Colorable (ReprOf d) => Trans d => d -> d
304 default onBluer :: Colorable (ReprOf d) => Trans d => d -> d
305 default onMagentaer :: Colorable (ReprOf d) => Trans d => d -> d
306 default onCyaner :: Colorable (ReprOf d) => Trans d => d -> d
307 default onWhiter :: Colorable (ReprOf d) => Trans d => d -> d
309 reverse = trans1 reverse
313 yellow = trans1 yellow
315 magenta = trans1 magenta
318 blacker = trans1 blacker
319 redder = trans1 redder
320 greener = trans1 greener
321 yellower = trans1 yellower
323 magentaer = trans1 magentaer
324 cyaner = trans1 cyaner
325 whiter = trans1 whiter
326 onBlack = trans1 onBlack
328 onGreen = trans1 onGreen
329 onYellow = trans1 onYellow
330 onBlue = trans1 onBlue
331 onMagenta = trans1 onMagenta
332 onCyan = trans1 onCyan
333 onWhite = trans1 onWhite
334 onBlacker = trans1 onBlacker
335 onRedder = trans1 onRedder
336 onGreener = trans1 onGreener
337 onYellower = trans1 onYellower
338 onBluer = trans1 onBluer
339 onMagentaer = trans1 onMagentaer
340 onCyaner = trans1 onCyaner
341 onWhiter = trans1 onWhiter
343 -- * Class 'Decorable'
344 class Decorable d where
345 -- | @('decorable' f)@ write @f@ applied to whether decorations are activated or not.
346 decorable :: (Bool -> d) -> d
347 -- | @('withColor' b d)@ whether to active decorations or not within @d@.
348 withDecorable :: Bool -> d -> d
353 default bold :: Decorable (ReprOf d) => Trans d => d -> d
354 default underline :: Decorable (ReprOf d) => Trans d => d -> d
355 default italic :: Decorable (ReprOf d) => Trans d => d -> d
357 underline = trans1 underline
358 italic = trans1 italic
362 -- | Return the underlying @tr@ of the transformer.
365 -- | Lift a tr to the transformer's.
366 trans :: ReprOf tr -> tr
367 -- | Unlift a tr from the transformer's.
368 unTrans :: tr -> ReprOf tr
370 -- | Identity transformation for a unary symantic method.
371 trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
372 trans1 f = trans . f . unTrans
374 -- | Identity transformation for a binary symantic method.
376 :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
378 trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
380 -- | Identity transformation for a ternary symantic method.
382 :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
383 -> (tr -> tr -> tr -> tr)
384 trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))
386 -- | Break a 'String' into lines while preserving all empty lines.
387 lines :: String -> [String]
389 case List.break (== '\n') cs of
390 (chunk, _:rest) -> chunk : lines rest
391 (chunk, []) -> [chunk]