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
35 -- * Class 'Lengthable'
36 class Lengthable a where
38 instance Lengthable Char where
40 instance Lengthable [a] where
41 length = Nat . fromIntegral . List.length
42 instance Lengthable Text.Text where
43 length = Nat . fromIntegral . Text.length
44 instance Lengthable TL.Text where
45 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)@ write @f@ applied to the current 'Column'.
135 column :: (Column -> d) -> d
136 -- | @('endToEndWidth' d f)@ write @d@ then
137 -- @f@ applied to the difference between
138 -- the end 'Column' and start 'Column' of @d@.
140 -- Note that @f@ is given the end-to-end width,
141 -- which is not necessarily the maximal width.
142 endToEndWidth :: d -> (Column -> d) -> d
143 endToEndWidth d f = column $ \c1 -> (d <>) $ column $ \c2 -> f $ c2 - c1
145 -- | @'spaces' ind = 'replicate' ind 'space'@
146 spaces :: Indent -> d
147 spaces i = replicate (fromIntegral i) space
149 -- | @('fill' ind d)@ write @d@,
150 -- then if @d@ is not wider than @ind@,
151 -- write the difference with 'spaces'.
152 fill :: Indent -> d -> d
154 endToEndWidth d $ \w ->
159 -- | @('breakableFill' ind d)@ write @d@,
160 -- then if @d@ is not wider than @ind@, write the difference with 'spaces'
161 -- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @ind@.
162 breakableFill :: Indent -> d -> d
165 endToEndWidth d $ \w ->
167 LT -> spaces (m - w) <> empty
169 GT -> withIndent (c + m) newline
171 -- * Class 'Wrapable'
172 class (Textable d, Alignable d) => Wrapable d where
173 -- | @('ifWrap' onWrap onNoWrap)@
174 -- write @onWrap@ if @onNoWrap@ leads to a 'Column'
175 -- greater or equal to the one sets with 'withWrapColumn',
176 -- otherwise write @onNoWrap@.
177 ifWrap :: d -> d -> d
178 -- | @('breakpoint' onNoBreak onBreak d)@
179 -- write @onNoBreak@ then @d@ if they fit,
180 -- @onBreak@ otherwise.
181 breakpoint :: d -> d -> d -> d
182 -- | @('breakableEmpty' d)@ write @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)@ write '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 -- write @ds@ with @sep@ intercalated if the whole fits,
203 -- otherwise write '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)@ write @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)@ write @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]