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.Ord (Ord(..), Ordering(..))
12 import Data.Semigroup (Semigroup(..))
13 import Data.String (String, IsString)
14 import Prelude (Integer, toInteger, fromIntegral, Num(..), undefined, Integral, Real, Enum)
15 import Text.Show (Show)
16 import qualified Data.List as List
17 import qualified Data.Text as Text
18 import qualified Data.Text.Lazy as TL
21 newtype Nat = Nat Integer
22 deriving (Eq, Ord, Show, Integral, Real, Enum)
23 unLength :: Nat -> Integer
25 instance Num Nat where
26 fromInteger i | 0 <= i = Nat i
27 | otherwise = undefined
28 abs = Nat . abs . unLength
29 signum = signum . signum
30 Nat x + Nat y = Nat (x + y)
31 Nat x * Nat y = Nat (x * y)
32 Nat x - Nat y | y <= x = Nat (x - y)
33 | otherwise = undefined
41 -- * Class 'Lengthable'
42 class Lengthable a where
44 instance Lengthable Char where
46 instance Lengthable [a] where
47 length = Nat . fromIntegral . List.length
48 instance Lengthable Text.Text where
49 length = Nat . fromIntegral . Text.length
50 instance Lengthable TL.Text where
51 length = Nat . fromIntegral . TL.length
54 class (IsString d, Semigroup d) => Textable d where
55 charH :: Char -- ^ XXX: MUST NOT be '\n'
57 stringH :: String -- ^ XXX: MUST NOT contain '\n'
59 textH :: Text.Text -- ^ XXX: MUST NOT contain '\n'
61 ltextH :: TL.Text -- ^ XXX: MUST NOT contain '\n'
63 replicate :: Int -> d -> d
64 integer :: Integer -> d
65 default replicate :: Textable (ReprOf d) => Trans d => Int -> d -> d
66 default integer :: Textable (ReprOf d) => Trans d => Integer -> d
67 default charH :: Textable (ReprOf d) => Trans d => Char -> d
68 default stringH :: Textable (ReprOf d) => Trans d => String -> d
69 default textH :: Textable (ReprOf d) => Trans d => Text.Text -> d
70 default ltextH :: Textable (ReprOf d) => Trans d => TL.Text -> d
72 stringH = trans . stringH
74 ltextH = trans . ltextH
75 replicate = trans1 . replicate
76 integer = trans . integer
81 -- | @x '<+>' y = x '<>' 'space' '<>' y@
83 -- | @x '</>' y = x '<>' 'newline' '<>' y@
88 text :: Text.Text -> d
90 catH :: Foldable f => f d -> d
91 catV :: 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
99 x <+> y = x <> space <> y
100 x </> y = x <> newline <> y
101 int = integer . toInteger
102 char = \case '\n' -> newline; c -> charH c
103 string = catV . fmap stringH . lines
104 text = catV . fmap textH . Text.lines
105 ltext = catV . fmap ltextH . TL.lines
106 catH = foldr (<>) empty
107 catV = foldrWith (\x y -> x<>newline<>y)
108 foldrWith f ds = if null ds then empty else foldr1 f ds
109 foldWith f = foldrWith $ \a acc -> a <> f acc
110 intercalate sep = foldrWith (\x y -> x<>sep<>y)
111 between o c d = o<>d<>c
112 -- default catH :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
113 -- default catV :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
114 -- catH l = trans (catH (fmap unTrans l))
115 -- catV l = trans (catV (fmap unTrans l))
117 -- * Class 'Alignable'
118 class Textable d => Alignable d where
119 -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
121 -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
122 hang :: Indent -> d -> d
123 hang ind = align . incrIndent ind
124 -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
125 incrIndent :: Indent -> d -> d
126 -- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
127 withIndent :: Indent -> d -> d
128 -- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.
130 -- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.
131 withNewline :: d -> d -> d
132 newlineWithoutIndent :: d
133 newlineWithIndent :: d
134 -- | @('column' f)@ return @f@ applied to the current 'Column'.
135 column :: (Column -> d) -> d
136 -- | @('endToEndWidth' d f)@ return @d@ concatenated to
137 -- @f@ applied to the difference between the end 'Column' and start 'Column' of @d@.
139 -- Note that @f@ is given the end-to-end width,
140 -- which is not necessarily the maximal width.
141 endToEndWidth :: d -> (Column -> d) -> d
142 endToEndWidth d f = column $ \(Nat c1) -> (d <>) $ column $ \(Nat c2) -> f $ Nat $ c2 - c1
144 -- | @'spaces' ind = 'replicate' ind 'space'@
145 spaces :: Indent -> d
146 spaces (Nat i) = replicate (fromIntegral i) space
148 -- | @('fill' ind d)@ return @d@ then as many 'space's as needed
149 -- so that the whole is @ind@ 'Column's wide.
150 fill :: Indent -> d -> d
152 endToEndWidth d $ \(Nat w) ->
154 LT -> spaces $ Nat $ m - w
157 -- | @('breakableFill' ind f d)@ return @f@ then as many 'space's as needed
158 -- so that the whole is @ind@ 'Column's wide,
159 -- then, if @f@ is not wider than @ind@, appends @d@,
160 -- otherwise appends a 'newline' and @d@,
161 -- with an 'Indent' level set to the start 'Column' of @f@ plus @ind@.
162 breakableFill :: Indent -> d -> d -> d
163 breakableFill (Nat m) f d =
165 endToEndWidth f $ \(Nat w) ->
167 LT -> spaces (Nat $ m - w) <> d
169 GT -> withIndent (Nat $ c + m) (newline <> d)
171 -- * Class 'Wrapable'
172 class (Textable d, Alignable d) => Wrapable d where
173 -- | @('ifWrap' onWrap onNoWrap)@
174 -- return @onWrap@ if @onNoWrap@ leads to a 'Column'
175 -- greater or equal to the one sets with 'withWrapColumn',
176 -- otherwise return @onNoWrap@.
177 ifWrap :: d -> d -> d
178 -- | @('breakpoint' onNoBreak onBreak d)@
179 -- return @onNoBreak@ then @d@ if they fit,
180 -- @onBreak@ otherwise.
181 breakpoint :: d -> d -> d -> d
182 -- | @('breakableEmpty' d)@ return @d@ if it fits, 'newline' then @d@ otherwise.
183 breakableEmpty :: d -> d
184 breakableEmpty = breakpoint empty newline
185 -- | @x '><' y = x '<>' 'breakableEmpty' y@
187 x >< y = x <> breakableEmpty y
188 -- | @('breakableSpace' d)@ return 'space' then @d@ it they fit,
189 -- 'newline' then @d@ otherwise.
190 breakableSpace :: d -> d
191 breakableSpace = breakpoint space newline
192 -- | @x '>+<' y = x '<>' 'breakableSpace' y@
194 x >+< y = x <> breakableSpace y
195 -- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
196 -- between items of @ds@.
197 breakableSpaces :: Foldable f => f d -> d
198 breakableSpaces = foldWith breakableSpace
199 -- | @'withWrapColumn' col d@ set the 'Column' triggering wrapping to @col@ within @d@.
200 withWrapColumn :: Column -> d -> d
201 -- | @('intercalateHorV' sep ds)@
202 -- return @ds@ with @sep@ intercalated if the whole fits,
203 -- otherwise return 'align' of @ds@ with 'newline' and @sep@ intercalated.
204 intercalateHorV :: Foldable f => d -> f d -> d
205 intercalateHorV sep xs =
207 (align $ foldWith ((newline <> sep) <>) xs)
208 (foldWith (sep <>) xs)
210 -- * Class 'Colorable'
211 class Colorable d where
212 -- | @('colorable' f)@ return @f@ applied to whether colors are activated or not.
213 colorable :: (Bool -> d) -> d
214 -- | @('withColor' b d)@ whether to active colors or not within @d@.
215 withColorable :: Bool -> d -> d
257 onMagentaer :: d -> d
261 default reverse :: Colorable (ReprOf d) => Trans d => d -> d
262 default black :: Colorable (ReprOf d) => Trans d => d -> d
263 default red :: Colorable (ReprOf d) => Trans d => d -> d
264 default green :: Colorable (ReprOf d) => Trans d => d -> d
265 default yellow :: Colorable (ReprOf d) => Trans d => d -> d
266 default blue :: Colorable (ReprOf d) => Trans d => d -> d
267 default magenta :: Colorable (ReprOf d) => Trans d => d -> d
268 default cyan :: Colorable (ReprOf d) => Trans d => d -> d
269 default white :: Colorable (ReprOf d) => Trans d => d -> d
270 default blacker :: Colorable (ReprOf d) => Trans d => d -> d
271 default redder :: Colorable (ReprOf d) => Trans d => d -> d
272 default greener :: Colorable (ReprOf d) => Trans d => d -> d
273 default yellower :: Colorable (ReprOf d) => Trans d => d -> d
274 default bluer :: Colorable (ReprOf d) => Trans d => d -> d
275 default magentaer :: Colorable (ReprOf d) => Trans d => d -> d
276 default cyaner :: Colorable (ReprOf d) => Trans d => d -> d
277 default whiter :: Colorable (ReprOf d) => Trans d => d -> d
278 default onBlack :: Colorable (ReprOf d) => Trans d => d -> d
279 default onRed :: Colorable (ReprOf d) => Trans d => d -> d
280 default onGreen :: Colorable (ReprOf d) => Trans d => d -> d
281 default onYellow :: Colorable (ReprOf d) => Trans d => d -> d
282 default onBlue :: Colorable (ReprOf d) => Trans d => d -> d
283 default onMagenta :: Colorable (ReprOf d) => Trans d => d -> d
284 default onCyan :: Colorable (ReprOf d) => Trans d => d -> d
285 default onWhite :: Colorable (ReprOf d) => Trans d => d -> d
286 default onBlacker :: Colorable (ReprOf d) => Trans d => d -> d
287 default onRedder :: Colorable (ReprOf d) => Trans d => d -> d
288 default onGreener :: Colorable (ReprOf d) => Trans d => d -> d
289 default onYellower :: Colorable (ReprOf d) => Trans d => d -> d
290 default onBluer :: Colorable (ReprOf d) => Trans d => d -> d
291 default onMagentaer :: Colorable (ReprOf d) => Trans d => d -> d
292 default onCyaner :: Colorable (ReprOf d) => Trans d => d -> d
293 default onWhiter :: Colorable (ReprOf d) => Trans d => d -> d
295 reverse = trans1 reverse
299 yellow = trans1 yellow
301 magenta = trans1 magenta
304 blacker = trans1 blacker
305 redder = trans1 redder
306 greener = trans1 greener
307 yellower = trans1 yellower
309 magentaer = trans1 magentaer
310 cyaner = trans1 cyaner
311 whiter = trans1 whiter
312 onBlack = trans1 onBlack
314 onGreen = trans1 onGreen
315 onYellow = trans1 onYellow
316 onBlue = trans1 onBlue
317 onMagenta = trans1 onMagenta
318 onCyan = trans1 onCyan
319 onWhite = trans1 onWhite
320 onBlacker = trans1 onBlacker
321 onRedder = trans1 onRedder
322 onGreener = trans1 onGreener
323 onYellower = trans1 onYellower
324 onBluer = trans1 onBluer
325 onMagentaer = trans1 onMagentaer
326 onCyaner = trans1 onCyaner
327 onWhiter = trans1 onWhiter
329 -- * Class 'Decorable'
330 class Decorable d where
331 -- | @('decorable' f)@ return @f@ applied to whether decorations are activated or not.
332 decorable :: (Bool -> d) -> d
333 -- | @('withColor' b d)@ whether to active decorations or not within @d@.
334 withDecorable :: Bool -> d -> d
339 default bold :: Decorable (ReprOf d) => Trans d => d -> d
340 default underline :: Decorable (ReprOf d) => Trans d => d -> d
341 default italic :: Decorable (ReprOf d) => Trans d => d -> d
343 underline = trans1 underline
344 italic = trans1 italic
348 -- | Return the underlying @tr@ of the transformer.
351 -- | Lift a tr to the transformer's.
352 trans :: ReprOf tr -> tr
353 -- | Unlift a tr from the transformer's.
354 unTrans :: tr -> ReprOf tr
356 -- | Identity transformation for a unary symantic method.
357 trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
358 trans1 f = trans . f . unTrans
360 -- | Identity transformation for a binary symantic method.
362 :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
364 trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
366 -- | Identity transformation for a ternary symantic method.
368 :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
369 -> (tr -> tr -> tr -> tr)
370 trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))
372 -- | Break a 'String' into lines while preserving all empty lines.
373 lines :: String -> [String]
375 case List.break (== '\n') cs of
376 (chunk, _:rest) -> chunk : lines rest
377 (chunk, []) -> [chunk]