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 }
  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         string      :: String  -> d
 117         text        :: Text.Text  -> d
 118         ltext       :: TL.Text -> d
 119         catH        :: Foldable f => f d -> d
 120         catV        :: Foldable f => f d -> d
 121         unwords     :: Foldable f => f d -> d
 122         unlines     :: Foldable f => f d -> d
 123         foldrWith   :: Foldable f => (d -> d -> d) -> f d -> d
 124         foldWith    :: Foldable f => (d -> d) -> f d -> d
 125         intercalate :: Foldable f => d -> f d -> d
 126         between     :: d -> d -> d -> d
 127         replicate   :: Int -> d -> d
 128
 129         newline = "\n"
 130         space   = char ' '
 131         x <+> y = x <> space <> y
 132         x </> y = x <> newline <> y
 133         int     = stringH . show
 134         integer = stringH . show
 135         char    = \case '\n' -> newline; c -> charH c
 136         string  = catV . fmap stringH . lines
 137         text    = catV . fmap textH   . lines
 138         ltext   = catV . fmap ltextH  . lines
 139         catH    = foldr (<>) empty
 140         catV    = foldrWith (\x y -> x<>newline<>y)
 141         unwords = foldr (<>) space
 142         unlines = foldr (\x y -> x<>newline<>y) empty
 143         foldrWith f ds  = if Foldable.null ds then empty else foldr1 f ds
 144         foldWith  f     = foldrWith $ \a acc -> a <> f acc
 145         intercalate sep = foldrWith (\x y -> x<>sep<>y)
 146         between o c d = o<>d<>c
 147         replicate cnt t | cnt <= 0  = empty
 148                         | otherwise = t <> replicate (pred cnt) t
 149
 150 -- * Class 'Indentable'
 151 class Textable d => Indentable d where
 152         -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
 153         align :: d -> d
 154         default align :: Indentable (UnTrans d) => Trans d => d -> d
 155         align = noTrans1 align
 156         -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
 157         incrIndent :: Indent -> d -> d
 158         default incrIndent :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
 159         incrIndent = noTrans1 . incrIndent
 160         -- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
 161         withIndent :: Indent -> d -> d
 162         default withIndent :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
 163         withIndent = noTrans1 . withIndent
 164         -- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.
 165         --
 166         -- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.
 167         withNewline          :: d -> d -> d
 168         newlineWithoutIndent :: d
 169         newlineWithIndent    :: d
 170         default withNewline          :: Indentable (UnTrans d) => Trans d => d -> d -> d
 171         default newlineWithoutIndent :: Indentable (UnTrans d) => Trans d => d
 172         default newlineWithIndent    :: Indentable (UnTrans d) => Trans d => d
 173         withNewline          = noTrans2 withNewline
 174         newlineWithoutIndent = noTrans newlineWithoutIndent
 175         newlineWithIndent    = noTrans newlineWithIndent
 176         -- | @('column' f)@ write @f@ applied to the current 'Column'.
 177         column :: (Column -> d) -> d
 178         default column :: Indentable (UnTrans d) => Trans d => (Column -> d) -> d
 179         column f = noTrans $ column (unTrans . f)
 180         -- | @('indent' f)@ write @f@ applied to the current 'Indent'.
 181         indent :: (Indent -> d) -> d
 182         default indent :: Indentable (UnTrans d) => Trans d => (Indent -> d) -> d
 183         indent f = noTrans $ indent (unTrans . f)
 184
 185         -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
 186         hang :: Indent -> d -> d
 187         hang ind = align . incrIndent ind
 188
 189         -- | @('endToEndWidth' d f)@ write @d@ then
 190         -- @f@ applied to the absolute value of the difference between
 191         -- the end 'Column' and start 'Column' of @d@.
 192         --
 193         -- Note that @f@ is given the end-to-end width,
 194         -- which is not necessarily the maximal width.
 195         endToEndWidth :: d -> (Column -> d) -> d
 196         endToEndWidth d f =
 197                 column $ \c1 ->
 198                         (d <>) $
 199                         column $ \c2 ->
 200                         f $ if c2 - c1 >= 0
 201                                 then c2 - c1
 202                                 else c1 - c2
 203
 204         -- | @'spaces' ind = 'replicate' ind 'space'@
 205         spaces :: Indent -> d
 206         spaces i = replicate (fromIntegral i) space
 207
 208         -- | @('fill' ind d)@ write @d@,
 209         -- then if @d@ is not wider than @ind@,
 210         -- write the difference with 'spaces'.
 211         fill :: Indent -> d -> d
 212         fill m d =
 213                 endToEndWidth d $ \w ->
 214                         case w`compare`m of
 215                          LT -> spaces $ m - w
 216                          _  -> empty
 217
 218         -- | @('breakableFill' ind d)@ write @d@,
 219         -- then if @d@ is not wider than @ind@, write the difference with 'spaces'
 220         -- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @ind@.
 221         breakableFill :: Indent -> d -> d
 222         breakableFill m d =
 223                 column $ \c ->
 224                 endToEndWidth d $ \w ->
 225                         case w`compare`m of
 226                          LT -> spaces (m - w)
 227                          EQ -> empty
 228                          GT -> withIndent (c + m) newline
 229
 230 -- * Class 'Breakable'
 231 class (Textable d, Indentable d) => Breakable d where
 232         -- | @('breakable' f)@ write @f@ applied to whether breaks are activated or not.
 233         breakable :: (Maybe Column -> d) -> d
 234         default breakable :: Breakable (UnTrans d) => Trans d => (Maybe Column -> d) -> d
 235         breakable f = noTrans $ breakable (unTrans . f)
 236         -- | @('withBreakable' b d)@ whether to active breaks or not within @d@.
 237         withBreakable :: Maybe Column -> d -> d
 238         default withBreakable :: Breakable (UnTrans d) => Trans d => Maybe Column -> d -> d
 239         withBreakable = noTrans1 . withBreakable
 240
 241         -- | @('ifBreak' onWrap onNoWrap)@
 242         -- write @onWrap@ if @onNoWrap@ leads to a 'Column'
 243         -- greater or equal to the one sets with 'withBreakable',
 244         -- otherwise write @onNoWrap@.
 245         ifBreak :: d -> d -> d
 246         default ifBreak :: Breakable (UnTrans d) => Trans d => d -> d -> d
 247         ifBreak = noTrans2 ifBreak
 248         -- | @('breakpoint' onNoBreak onBreak d)@
 249         -- write @onNoBreak@ then @d@ if they fit,
 250         -- @onBreak@ otherwise.
 251         breakpoint :: d -> d -> d -> d
 252         default breakpoint :: Breakable (UnTrans d) => Trans d => d -> d -> d -> d
 253         breakpoint = noTrans3 breakpoint
 254
 255         -- | @('breakableEmpty' d)@ write @d@ if it fits, 'newline' then @d@ otherwise.
 256         breakableEmpty :: d -> d
 257         breakableEmpty = breakpoint empty newline
 258
 259         -- | @x '><' y = x '<>' 'breakableEmpty' y@
 260         (><) :: d -> d -> d
 261         x >< y = x <> breakableEmpty y
 262
 263         -- | @('breakableSpace' d)@ write 'space' then @d@ it they fit,
 264         -- 'newline' then @d@ otherwise.
 265         breakableSpace :: d -> d
 266         breakableSpace = breakpoint space newline
 267
 268         -- | @x '>+<' y = x '<>' 'breakableSpace' y@
 269         (>+<) :: d -> d -> d
 270         x >+< y = x <> breakableSpace y
 271
 272         -- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
 273         -- between items of @ds@.
 274         breakableSpaces :: Foldable f => f d -> d
 275         breakableSpaces = foldWith breakableSpace
 276
 277         -- | @('intercalateHorV' sep ds)@
 278         -- write @ds@ with @sep@ intercalated if the whole fits,
 279         -- otherwise write 'align' of @ds@ with 'newline' and @sep@ intercalated.
 280         intercalateHorV :: Foldable f => d -> f d -> d
 281         intercalateHorV sep xs =
 282                 ifBreak
 283                  (align $ foldWith ((newline <> sep) <>) xs)
 284                  (foldWith (sep <>) xs)
 285
 286 -- * Class 'Colorable'
 287 class Colorable d where
 288         -- | @('colorable' f)@ write @f@ applied to whether colors are activated or not.
 289         colorable :: (Bool -> d) -> d
 290         default colorable :: Colorable (UnTrans d) => Trans d => (Bool -> d) -> d
 291         colorable f = noTrans $ colorable (unTrans . f)
 292         -- | @('withColor' b d)@ whether to active colors or not within @d@.
 293         withColorable :: Bool -> d -> d
 294         default withColorable :: Colorable (UnTrans d) => Trans d => Bool -> d -> d
 295         withColorable = noTrans1 . withColorable
 296
 297         reverse :: d -> d
 298
 299         -- Foreground colors
 300         -- Dull
 301         black   :: d -> d
 302         red     :: d -> d
 303         green   :: d -> d
 304         yellow  :: d -> d
 305         blue    :: d -> d
 306         magenta :: d -> d
 307         cyan    :: d -> d
 308         white   :: d -> d
 309
 310         -- Vivid
 311         blacker   :: d -> d
 312         redder    :: d -> d
 313         greener   :: d -> d
 314         yellower  :: d -> d
 315         bluer     :: d -> d
 316         magentaer :: d -> d
 317         cyaner    :: d -> d
 318         whiter    :: d -> d
 319
 320         -- Background colors
 321         -- Dull
 322         onBlack   :: d -> d
 323         onRed     :: d -> d
 324         onGreen   :: d -> d
 325         onYellow  :: d -> d
 326         onBlue    :: d -> d
 327         onMagenta :: d -> d
 328         onCyan    :: d -> d
 329         onWhite   :: d -> d
 330
 331         -- Vivid
 332         onBlacker   :: d -> d
 333         onRedder    :: d -> d
 334         onGreener   :: d -> d
 335         onYellower  :: d -> d
 336         onBluer     :: d -> d
 337         onMagentaer :: d -> d
 338         onCyaner    :: d -> d
 339         onWhiter    :: d -> d
 340
 341         default reverse     :: Colorable (UnTrans d) => Trans d => d -> d
 342         default black       :: Colorable (UnTrans d) => Trans d => d -> d
 343         default red         :: Colorable (UnTrans d) => Trans d => d -> d
 344         default green       :: Colorable (UnTrans d) => Trans d => d -> d
 345         default yellow      :: Colorable (UnTrans d) => Trans d => d -> d
 346         default blue        :: Colorable (UnTrans d) => Trans d => d -> d
 347         default magenta     :: Colorable (UnTrans d) => Trans d => d -> d
 348         default cyan        :: Colorable (UnTrans d) => Trans d => d -> d
 349         default white       :: Colorable (UnTrans d) => Trans d => d -> d
 350         default blacker     :: Colorable (UnTrans d) => Trans d => d -> d
 351         default redder      :: Colorable (UnTrans d) => Trans d => d -> d
 352         default greener     :: Colorable (UnTrans d) => Trans d => d -> d
 353         default yellower    :: Colorable (UnTrans d) => Trans d => d -> d
 354         default bluer       :: Colorable (UnTrans d) => Trans d => d -> d
 355         default magentaer   :: Colorable (UnTrans d) => Trans d => d -> d
 356         default cyaner      :: Colorable (UnTrans d) => Trans d => d -> d
 357         default whiter      :: Colorable (UnTrans d) => Trans d => d -> d
 358         default onBlack     :: Colorable (UnTrans d) => Trans d => d -> d
 359         default onRed       :: Colorable (UnTrans d) => Trans d => d -> d
 360         default onGreen     :: Colorable (UnTrans d) => Trans d => d -> d
 361         default onYellow    :: Colorable (UnTrans d) => Trans d => d -> d
 362         default onBlue      :: Colorable (UnTrans d) => Trans d => d -> d
 363         default onMagenta   :: Colorable (UnTrans d) => Trans d => d -> d
 364         default onCyan      :: Colorable (UnTrans d) => Trans d => d -> d
 365         default onWhite     :: Colorable (UnTrans d) => Trans d => d -> d
 366         default onBlacker   :: Colorable (UnTrans d) => Trans d => d -> d
 367         default onRedder    :: Colorable (UnTrans d) => Trans d => d -> d
 368         default onGreener   :: Colorable (UnTrans d) => Trans d => d -> d
 369         default onYellower  :: Colorable (UnTrans d) => Trans d => d -> d
 370         default onBluer     :: Colorable (UnTrans d) => Trans d => d -> d
 371         default onMagentaer :: Colorable (UnTrans d) => Trans d => d -> d
 372         default onCyaner    :: Colorable (UnTrans d) => Trans d => d -> d
 373         default onWhiter    :: Colorable (UnTrans d) => Trans d => d -> d
 374
 375         reverse     = noTrans1 reverse
 376         black       = noTrans1 black
 377         red         = noTrans1 red
 378         green       = noTrans1 green
 379         yellow      = noTrans1 yellow
 380         blue        = noTrans1 blue
 381         magenta     = noTrans1 magenta
 382         cyan        = noTrans1 cyan
 383         white       = noTrans1 white
 384         blacker     = noTrans1 blacker
 385         redder      = noTrans1 redder
 386         greener     = noTrans1 greener
 387         yellower    = noTrans1 yellower
 388         bluer       = noTrans1 bluer
 389         magentaer   = noTrans1 magentaer
 390         cyaner      = noTrans1 cyaner
 391         whiter      = noTrans1 whiter
 392         onBlack     = noTrans1 onBlack
 393         onRed       = noTrans1 onRed
 394         onGreen     = noTrans1 onGreen
 395         onYellow    = noTrans1 onYellow
 396         onBlue      = noTrans1 onBlue
 397         onMagenta   = noTrans1 onMagenta
 398         onCyan      = noTrans1 onCyan
 399         onWhite     = noTrans1 onWhite
 400         onBlacker   = noTrans1 onBlacker
 401         onRedder    = noTrans1 onRedder
 402         onGreener   = noTrans1 onGreener
 403         onYellower  = noTrans1 onYellower
 404         onBluer     = noTrans1 onBluer
 405         onMagentaer = noTrans1 onMagentaer
 406         onCyaner    = noTrans1 onCyaner
 407         onWhiter    = noTrans1 onWhiter
 408
 409 -- * Class 'Decorable'
 410 class Decorable d where
 411         -- | @('decorable' f)@ write @f@ applied to whether decorations are activated or not.
 412         decorable :: (Bool -> d) -> d
 413         default decorable :: Decorable (UnTrans d) => Trans d => (Bool -> d) -> d
 414         decorable f = noTrans $ decorable (unTrans . f)
 415         -- | @('withColor' b d)@ whether to active decorations or not within @d@.
 416         withDecorable :: Bool -> d -> d
 417         default withDecorable :: Decorable (UnTrans d) => Trans d => Bool -> d -> d
 418         withDecorable = noTrans1 . withDecorable
 419
 420         bold      :: d -> d
 421         underline :: d -> d
 422         italic    :: d -> d
 423         default bold      :: Decorable (UnTrans d) => Trans d => d -> d
 424         default underline :: Decorable (UnTrans d) => Trans d => d -> d
 425         default italic    :: Decorable (UnTrans d) => Trans d => d -> d
 426         bold      = noTrans1 bold
 427         underline = noTrans1 underline
 428         italic    = noTrans1 italic
 429
 430 -- * Class 'Trans'
 431 class Trans repr where
 432         -- | Return the underlying @repr@ of the transformer.
 433         type UnTrans repr :: *
 434
 435         -- | Lift a repr to the transformer's.
 436         noTrans :: UnTrans repr -> repr
 437         -- | Unlift a repr from the transformer's.
 438         unTrans :: repr -> UnTrans repr
 439
 440         -- | Identity transformation for a unary symantic method.
 441         noTrans1 :: (UnTrans repr -> UnTrans repr) -> (repr -> repr)
 442         noTrans1 f = noTrans . f . unTrans
 443
 444         -- | Identity transformation for a binary symantic method.
 445         noTrans2
 446          :: (UnTrans repr -> UnTrans repr -> UnTrans repr)
 447          -> (repr -> repr -> repr)
 448         noTrans2 f a b = noTrans (f (unTrans a) (unTrans b))
 449
 450         -- | Identity transformation for a ternary symantic method.
 451         noTrans3
 452          :: (UnTrans repr -> UnTrans repr -> UnTrans repr -> UnTrans repr)
 453          -> (repr -> repr -> repr -> repr)
 454         noTrans3 f a b c = noTrans (f (unTrans a) (unTrans b) (unTrans c))