symantic-document/Symantic/Document/Sym.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 module Symantic.Document.Sym where
   3
   4 import Data.Bool
   5 import Data.Char (Char)
   6 import Data.Eq (Eq(..))
   7 import Data.Foldable (Foldable, foldr, foldr1)
   8 import Data.Function ((.), ($))
   9 import Data.Functor (Functor(..))
  10 import Data.Int (Int)
  11 import Data.Maybe (Maybe(..))
  12 import Data.Monoid (Monoid(..))
  13 import Data.Ord (Ord(..), Ordering(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.String (String, IsString)
  16 import Prelude (Integer, fromIntegral, Num(..), pred, undefined, Integral, Real, Enum)
  17 import Text.Show (Show(..))
  18 import qualified Data.Foldable as Foldable
  19 import qualified Data.List as List
  20 import qualified Data.Text as Text
  21 import qualified Data.Text.Lazy as TL
  22
  23 -- * Type 'Nat'
  24 newtype Nat = Nat { unNat :: Integer } -- TODO: use GHC's Natural
  25  deriving (Eq, Ord, Show, Integral, Real, Enum)
  26 unLength :: Nat -> Integer
  27 unLength (Nat i) = i
  28 instance Num Nat where
  29         fromInteger i | 0 <= i    = Nat i
  30                       | otherwise = undefined
  31         abs = Nat . abs . unLength
  32         signum = signum . signum
  33         Nat x + Nat y = Nat (x + y)
  34         Nat x * Nat y = Nat (x * y)
  35         Nat x - Nat y | x >= y    = Nat (x - y)
  36                       | otherwise = undefined
  37
  38 -- * Class 'Lengthable'
  39 class Lengthable a where
  40         length :: a -> Nat
  41 instance Lengthable Char where
  42         length _ = Nat 1
  43 instance Lengthable [a] where
  44         length = Nat . fromIntegral . List.length
  45 instance Lengthable Text.Text where
  46         length = Nat . fromIntegral . Text.length
  47 instance Lengthable TL.Text where
  48         length = Nat . fromIntegral . TL.length
  49
  50 -- * Class 'Splitable'
  51 class Monoid a => Splitable a where
  52         null  :: a -> Bool
  53         tail  :: a -> a
  54         break :: (Char -> Bool) -> a -> (a, a)
  55         lines :: a -> [a]
  56         lines = splitOnChar (== '\n')
  57         words :: a -> [a]
  58         words = splitOnChar (== ' ')
  59         splitOnChar :: (Char -> Bool) -> a -> [a]
  60         splitOnChar c a =
  61                 if null a then []
  62                 else let (l,a') = break c a in
  63                         l : if null a' then []
  64                                 else let a'' = tail a' in
  65                                         if null a'' then [mempty] else splitOnChar c a''
  66 instance Splitable String where
  67         null  = List.null
  68         tail  = List.tail
  69         break = List.break
  70 instance Splitable Text.Text where
  71         null  = Text.null
  72         tail  = Text.tail
  73         break = Text.break
  74 instance Splitable TL.Text where
  75         null  = TL.null
  76         tail  = TL.tail
  77         break = TL.break
  78
  79 -- * Type 'Column'
  80 type Column = Nat
  81
  82 -- ** Type 'Indent'
  83 type Indent = Column
  84
  85 -- * Class 'Textable'
  86 class (IsString d, Semigroup d) => Textable d where
  87         empty     :: d
  88         charH     :: Char -- ^ XXX: MUST NOT be '\n'
  89                   -> d
  90         stringH   :: String -- ^ XXX: MUST NOT contain '\n'
  91                   -> d
  92         textH     :: Text.Text -- ^ XXX: MUST NOT contain '\n'
  93                   -> d
  94         ltextH    :: TL.Text -- ^ XXX: MUST NOT contain '\n'
  95                   -> d
  96         default empty     :: Textable (UnTrans d) => Trans d => d
  97         default charH     :: Textable (UnTrans d) => Trans d => Char -> d
  98         default stringH   :: Textable (UnTrans d) => Trans d => String -> d
  99         default textH     :: Textable (UnTrans d) => Trans d => Text.Text -> d
 100         default ltextH    :: Textable (UnTrans d) => Trans d => TL.Text -> d
 101         empty     = noTrans empty
 102         charH     = noTrans . charH
 103         stringH   = noTrans . stringH
 104         textH     = noTrans . textH
 105         ltextH    = noTrans . ltextH
 106
 107         newline     :: d
 108         space       :: d
 109         -- | @x '<+>' y = x '<>' 'space' '<>' y@
 110         (<+>)       :: d -> d -> d
 111         -- | @x '</>' y = x '<>' 'newline' '<>' y@
 112         (</>)       :: d -> d -> d
 113         int         :: Int -> d
 114         integer     :: Integer -> d
 115         char        :: Char -> d
 116         -- | WARNING: trailing spaces @(' ')@ are not made 'breakableSpace's
 117         string      :: String -> d
 118         -- | WARNING: trailing spaces @(' ')@ are not made 'breakableSpace's
 119         text        :: Text.Text  -> d
 120         -- | WARNING: trailing spaces @(' ')@ are not made 'breakableSpace's
 121         ltext       :: TL.Text -> d
 122         catH        :: Foldable f => f d -> d
 123         catV        :: Foldable f => f d -> d
 124         unwords     :: Foldable f => f d -> d
 125         unlines     :: Foldable f => f d -> d
 126         foldrWith   :: Foldable f => (d -> d -> d) -> f d -> d
 127         interWith   :: Foldable f => (d -> d) -> f d -> d
 128         intercalate :: Foldable f => d -> f d -> d
 129         between     :: d -> d -> d -> d
 130         replicate   :: Int -> d -> d
 131
 132         newline = "\n"
 133         space   = char ' '
 134         x <+> y = x <> space <> y
 135         x </> y = x <> newline <> y
 136         int     = stringH . show
 137         integer = stringH . show
 138         char    = \case '\n' -> newline; c -> charH c
 139         default string :: Breakable d => String -> d
 140         default text   :: Breakable d => Text.Text -> d
 141         default ltext  :: Breakable d => TL.Text -> d
 142         string  = catV . fmap ((breakableSpaces . (fmap stringH) . words)) . lines
 143         text    = catV . fmap ((breakableSpaces . (fmap textH)   . words)) . lines
 144         ltext   = catV . fmap ((breakableSpaces . (fmap ltextH)  . words)) . lines
 145         catH    = foldr (<>) empty
 146         catV    = foldrWith (\x y -> x<>newline<>y)
 147         unwords = foldrWith (\x y -> x<>space<>y)
 148         unlines = foldr (\x y -> x<>newline<>y) empty
 149         foldrWith f ds  = if Foldable.null ds then empty else foldr1 f ds
 150         interWith  f    = foldrWith $ \a acc -> a <> f acc
 151         intercalate sep = foldrWith (\x y -> x<>sep<>y)
 152         between o c d = o<>d<>c
 153         replicate cnt t | cnt <= 0  = empty
 154                         | otherwise = t <> replicate (pred cnt) t
 155
 156 -- * Class 'Indentable'
 157 class Textable d => Indentable d where
 158         -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
 159         align :: d -> d
 160         default align :: Indentable (UnTrans d) => Trans d => d -> d
 161         align = noTrans1 align
 162         -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
 163         incrIndent :: Indent -> d -> d
 164         default incrIndent :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
 165         incrIndent = noTrans1 . incrIndent
 166         -- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
 167         withIndent :: Indent -> d -> d
 168         default withIndent :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
 169         withIndent = noTrans1 . withIndent
 170         -- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.
 171         --
 172         -- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.
 173         withNewline          :: d -> d -> d
 174         newlineWithoutIndent :: d
 175         newlineWithIndent    :: d
 176         default withNewline          :: Indentable (UnTrans d) => Trans d => d -> d -> d
 177         default newlineWithoutIndent :: Indentable (UnTrans d) => Trans d => d
 178         default newlineWithIndent    :: Indentable (UnTrans d) => Trans d => d
 179         withNewline          = noTrans2 withNewline
 180         newlineWithoutIndent = noTrans newlineWithoutIndent
 181         newlineWithIndent    = noTrans newlineWithIndent
 182         -- | @('column' f)@ write @f@ applied to the current 'Column'.
 183         column :: (Column -> d) -> d
 184         default column :: Indentable (UnTrans d) => Trans d => (Column -> d) -> d
 185         column f = noTrans $ column (unTrans . f)
 186         -- | @('indent' f)@ write @f@ applied to the current 'Indent'.
 187         indent :: (Indent -> d) -> d
 188         default indent :: Indentable (UnTrans d) => Trans d => (Indent -> d) -> d
 189         indent f = noTrans $ indent (unTrans . f)
 190
 191         -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
 192         hang :: Indent -> d -> d
 193         hang ind = align . incrIndent ind
 194
 195         -- | @('endToEndWidth' d f)@ write @d@ then
 196         -- @f@ applied to the absolute value of the difference between
 197         -- the end 'Column' and start 'Column' of @d@.
 198         --
 199         -- Note that @f@ is given the end-to-end width,
 200         -- which is not necessarily the maximal width.
 201         endToEndWidth :: d -> (Column -> d) -> d
 202         endToEndWidth d f =
 203                 column $ \c1 ->
 204                         (d <>) $
 205                         column $ \c2 ->
 206                         f $ if c2 - c1 >= 0
 207                                 then c2 - c1
 208                                 else c1 - c2
 209
 210         -- | @'spaces' ind = 'replicate' ind 'space'@
 211         spaces :: Indent -> d
 212         spaces i = replicate (fromIntegral i) space
 213
 214         -- | @('fill' ind d)@ write @d@,
 215         -- then if @d@ is not wider than @ind@,
 216         -- write the difference with 'spaces'.
 217         fill :: Indent -> d -> d
 218         fill m d =
 219                 endToEndWidth d $ \w ->
 220                         case w`compare`m of
 221                          LT -> spaces $ m - w
 222                          _  -> empty
 223
 224         -- | @('breakableFill' ind d)@ write @d@,
 225         -- then if @d@ is not wider than @ind@, write the difference with 'spaces'
 226         -- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @ind@.
 227         breakableFill :: Indent -> d -> d
 228         breakableFill m d =
 229                 column $ \c ->
 230                 endToEndWidth d $ \w ->
 231                         case w`compare`m of
 232                          LT -> spaces (m - w)
 233                          EQ -> empty
 234                          GT -> withIndent (c + m) newline
 235
 236 -- * Class 'Breakable'
 237 class (Textable d, Indentable d) => Breakable d where
 238         -- | @('breakable' f)@ write @f@ applied to whether breaks are activated or not.
 239         breakable :: (Maybe Column -> d) -> d
 240         default breakable :: Breakable (UnTrans d) => Trans d => (Maybe Column -> d) -> d
 241         breakable f = noTrans $ breakable (unTrans . f)
 242         -- | @('withBreakable' b d)@ whether to active breaks or not within @d@.
 243         withBreakable :: Maybe Column -> d -> d
 244         default withBreakable :: Breakable (UnTrans d) => Trans d => Maybe Column -> d -> d
 245         withBreakable = noTrans1 . withBreakable
 246
 247         -- | @('ifBreak' onWrap onNoWrap)@
 248         -- write @onWrap@ if @onNoWrap@ leads to a 'Column'
 249         -- greater or equal to the one sets with 'withBreakable',
 250         -- otherwise write @onNoWrap@.
 251         ifBreak :: d -> d -> d
 252         default ifBreak :: Breakable (UnTrans d) => Trans d => d -> d -> d
 253         ifBreak = noTrans2 ifBreak
 254         -- | @('breakpoint' onNoBreak onBreak d)@
 255         -- write @onNoBreak@ then @d@ if they fit,
 256         -- @onBreak@ otherwise.
 257         breakpoint :: d -> d -> d -> d
 258         default breakpoint :: Breakable (UnTrans d) => Trans d => d -> d -> d -> d
 259         breakpoint = noTrans3 breakpoint
 260
 261         -- | @('breakableEmpty' d)@ write @d@ if it fits, 'newline' then @d@ otherwise.
 262         breakableEmpty :: d -> d
 263         breakableEmpty = breakpoint empty newline
 264
 265         -- | @x '><' y = x '<>' 'breakableEmpty' y@
 266         (><) :: d -> d -> d
 267         x >< y = x <> breakableEmpty y
 268
 269         -- | @('breakableSpace' d)@ write 'space' then @d@ it they fit,
 270         -- 'newline' then @d@ otherwise.
 271         breakableSpace :: d -> d
 272         breakableSpace = breakpoint space newline
 273
 274         -- | @x '>+<' y = x '<>' 'breakableSpace' y@
 275         (>+<) :: d -> d -> d
 276         x >+< y = x <> breakableSpace y
 277
 278         -- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
 279         -- between items of @ds@.
 280         breakableSpaces :: Foldable f => f d -> d
 281         breakableSpaces = interWith breakableSpace
 282
 283         -- | @('intercalateHorV' sep ds)@
 284         -- write @ds@ with @sep@ intercalated if the whole fits,
 285         -- otherwise write 'align' of @ds@ with 'newline' and @sep@ intercalated.
 286         intercalateHorV :: Foldable f => d -> f d -> d
 287         intercalateHorV sep xs =
 288                 ifBreak
 289                  (align $ interWith ((newline <> sep) <>) xs)
 290                  (interWith (sep <>) xs)
 291
 292 -- * Class 'Colorable'
 293 class Colorable d where
 294         -- | @('colorable' f)@ write @f@ applied to whether colors are activated or not.
 295         colorable :: (Bool -> d) -> d
 296         default colorable :: Colorable (UnTrans d) => Trans d => (Bool -> d) -> d
 297         colorable f = noTrans $ colorable (unTrans . f)
 298         -- | @('withColor' b d)@ whether to active colors or not within @d@.
 299         withColorable :: Bool -> d -> d
 300         default withColorable :: Colorable (UnTrans d) => Trans d => Bool -> d -> d
 301         withColorable = noTrans1 . withColorable
 302
 303         reverse :: d -> d
 304
 305         -- Foreground colors
 306         -- Dull
 307         black   :: d -> d
 308         red     :: d -> d
 309         green   :: d -> d
 310         yellow  :: d -> d
 311         blue    :: d -> d
 312         magenta :: d -> d
 313         cyan    :: d -> d
 314         white   :: d -> d
 315
 316         -- Vivid
 317         blacker   :: d -> d
 318         redder    :: d -> d
 319         greener   :: d -> d
 320         yellower  :: d -> d
 321         bluer     :: d -> d
 322         magentaer :: d -> d
 323         cyaner    :: d -> d
 324         whiter    :: d -> d
 325
 326         -- Background colors
 327         -- Dull
 328         onBlack   :: d -> d
 329         onRed     :: d -> d
 330         onGreen   :: d -> d
 331         onYellow  :: d -> d
 332         onBlue    :: d -> d
 333         onMagenta :: d -> d
 334         onCyan    :: d -> d
 335         onWhite   :: d -> d
 336
 337         -- Vivid
 338         onBlacker   :: d -> d
 339         onRedder    :: d -> d
 340         onGreener   :: d -> d
 341         onYellower  :: d -> d
 342         onBluer     :: d -> d
 343         onMagentaer :: d -> d
 344         onCyaner    :: d -> d
 345         onWhiter    :: d -> d
 346
 347         default reverse     :: Colorable (UnTrans d) => Trans d => d -> d
 348         default black       :: Colorable (UnTrans d) => Trans d => d -> d
 349         default red         :: Colorable (UnTrans d) => Trans d => d -> d
 350         default green       :: Colorable (UnTrans d) => Trans d => d -> d
 351         default yellow      :: Colorable (UnTrans d) => Trans d => d -> d
 352         default blue        :: Colorable (UnTrans d) => Trans d => d -> d
 353         default magenta     :: Colorable (UnTrans d) => Trans d => d -> d
 354         default cyan        :: Colorable (UnTrans d) => Trans d => d -> d
 355         default white       :: Colorable (UnTrans d) => Trans d => d -> d
 356         default blacker     :: Colorable (UnTrans d) => Trans d => d -> d
 357         default redder      :: Colorable (UnTrans d) => Trans d => d -> d
 358         default greener     :: Colorable (UnTrans d) => Trans d => d -> d
 359         default yellower    :: Colorable (UnTrans d) => Trans d => d -> d
 360         default bluer       :: Colorable (UnTrans d) => Trans d => d -> d
 361         default magentaer   :: Colorable (UnTrans d) => Trans d => d -> d
 362         default cyaner      :: Colorable (UnTrans d) => Trans d => d -> d
 363         default whiter      :: Colorable (UnTrans d) => Trans d => d -> d
 364         default onBlack     :: Colorable (UnTrans d) => Trans d => d -> d
 365         default onRed       :: Colorable (UnTrans d) => Trans d => d -> d
 366         default onGreen     :: Colorable (UnTrans d) => Trans d => d -> d
 367         default onYellow    :: Colorable (UnTrans d) => Trans d => d -> d
 368         default onBlue      :: Colorable (UnTrans d) => Trans d => d -> d
 369         default onMagenta   :: Colorable (UnTrans d) => Trans d => d -> d
 370         default onCyan      :: Colorable (UnTrans d) => Trans d => d -> d
 371         default onWhite     :: Colorable (UnTrans d) => Trans d => d -> d
 372         default onBlacker   :: Colorable (UnTrans d) => Trans d => d -> d
 373         default onRedder    :: Colorable (UnTrans d) => Trans d => d -> d
 374         default onGreener   :: Colorable (UnTrans d) => Trans d => d -> d
 375         default onYellower  :: Colorable (UnTrans d) => Trans d => d -> d
 376         default onBluer     :: Colorable (UnTrans d) => Trans d => d -> d
 377         default onMagentaer :: Colorable (UnTrans d) => Trans d => d -> d
 378         default onCyaner    :: Colorable (UnTrans d) => Trans d => d -> d
 379         default onWhiter    :: Colorable (UnTrans d) => Trans d => d -> d
 380
 381         reverse     = noTrans1 reverse
 382         black       = noTrans1 black
 383         red         = noTrans1 red
 384         green       = noTrans1 green
 385         yellow      = noTrans1 yellow
 386         blue        = noTrans1 blue
 387         magenta     = noTrans1 magenta
 388         cyan        = noTrans1 cyan
 389         white       = noTrans1 white
 390         blacker     = noTrans1 blacker
 391         redder      = noTrans1 redder
 392         greener     = noTrans1 greener
 393         yellower    = noTrans1 yellower
 394         bluer       = noTrans1 bluer
 395         magentaer   = noTrans1 magentaer
 396         cyaner      = noTrans1 cyaner
 397         whiter      = noTrans1 whiter
 398         onBlack     = noTrans1 onBlack
 399         onRed       = noTrans1 onRed
 400         onGreen     = noTrans1 onGreen
 401         onYellow    = noTrans1 onYellow
 402         onBlue      = noTrans1 onBlue
 403         onMagenta   = noTrans1 onMagenta
 404         onCyan      = noTrans1 onCyan
 405         onWhite     = noTrans1 onWhite
 406         onBlacker   = noTrans1 onBlacker
 407         onRedder    = noTrans1 onRedder
 408         onGreener   = noTrans1 onGreener
 409         onYellower  = noTrans1 onYellower
 410         onBluer     = noTrans1 onBluer
 411         onMagentaer = noTrans1 onMagentaer
 412         onCyaner    = noTrans1 onCyaner
 413         onWhiter    = noTrans1 onWhiter
 414
 415 -- * Class 'Decorable'
 416 class Decorable d where
 417         -- | @('decorable' f)@ write @f@ applied to whether decorations are activated or not.
 418         decorable :: (Bool -> d) -> d
 419         default decorable :: Decorable (UnTrans d) => Trans d => (Bool -> d) -> d
 420         decorable f = noTrans $ decorable (unTrans . f)
 421         -- | @('withColor' b d)@ whether to active decorations or not within @d@.
 422         withDecorable :: Bool -> d -> d
 423         default withDecorable :: Decorable (UnTrans d) => Trans d => Bool -> d -> d
 424         withDecorable = noTrans1 . withDecorable
 425
 426         bold      :: d -> d
 427         underline :: d -> d
 428         italic    :: d -> d
 429         default bold      :: Decorable (UnTrans d) => Trans d => d -> d
 430         default underline :: Decorable (UnTrans d) => Trans d => d -> d
 431         default italic    :: Decorable (UnTrans d) => Trans d => d -> d
 432         bold      = noTrans1 bold
 433         underline = noTrans1 underline
 434         italic    = noTrans1 italic
 435
 436 -- * Class 'Trans'
 437 class Trans repr where
 438         -- | Return the underlying @repr@ of the transformer.
 439         type UnTrans repr :: *
 440
 441         -- | Lift a repr to the transformer's.
 442         noTrans :: UnTrans repr -> repr
 443         -- | Unlift a repr from the transformer's.
 444         unTrans :: repr -> UnTrans repr
 445
 446         -- | Identity transformation for a unary symantic method.
 447         noTrans1 :: (UnTrans repr -> UnTrans repr) -> (repr -> repr)
 448         noTrans1 f = noTrans . f . unTrans
 449
 450         -- | Identity transformation for a binary symantic method.
 451         noTrans2
 452          :: (UnTrans repr -> UnTrans repr -> UnTrans repr)
 453          -> (repr -> repr -> repr)
 454         noTrans2 f a b = noTrans (f (unTrans a) (unTrans b))
 455
 456         -- | Identity transformation for a ternary symantic method.
 457         noTrans3
 458          :: (UnTrans repr -> UnTrans repr -> UnTrans repr -> UnTrans repr)
 459          -> (repr -> repr -> repr -> repr)
 460         noTrans3 f a b c = noTrans (f (unTrans a) (unTrans b) (unTrans c))