symantic-document/Language/Symantic/Document/Sym.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 module Language.Symantic.Document.Sym where
   3
   4 import Data.Bool
   5 import Data.Char (Char)
   6 import Data.Eq (Eq(..))
   7 import Data.Foldable (Foldable(..))
   8 import Data.Function ((.), ($))
   9 import Data.Functor (Functor(..))
  10 import Data.Int (Int)
  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
  20
  21 -- * Type 'Nat'
  22 newtype Nat = Nat Integer
  23  deriving (Eq, Ord, Show, Integral, Real, Enum)
  24 unLength :: Nat -> Integer
  25 unLength (Nat i) = i
  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
  35
  36 -- * Class 'Lengthable'
  37 class Lengthable a where
  38         length :: a -> Nat
  39 instance Lengthable Char where
  40         length _ = Nat 1
  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
  47
  48 -- * Type 'Column'
  49 type Column = Nat
  50
  51 -- ** Type 'Indent'
  52 type Indent = Column
  53
  54 -- * Class 'Textable'
  55 class (IsString d, Semigroup d) => Textable d where
  56         empty     :: d
  57         charH     :: Char -- ^ XXX: MUST NOT be '\n'
  58                   -> d
  59         stringH   :: String -- ^ XXX: MUST NOT contain '\n'
  60                   -> d
  61         textH     :: Text.Text -- ^ XXX: MUST NOT contain '\n'
  62                   -> d
  63         ltextH    :: TL.Text -- ^ XXX: MUST NOT contain '\n'
  64                   -> d
  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
  70         empty     = trans    empty
  71         charH     = trans  . charH
  72         stringH   = trans  . stringH
  73         textH     = trans  . textH
  74         ltextH    = trans  . ltextH
  75
  76         newline     :: d
  77         space       :: d
  78         -- | @x '<+>' y = x '<>' 'space' '<>' y@
  79         (<+>)       :: d -> d -> d
  80         -- | @x '</>' y = x '<>' 'newline' '<>' y@
  81         (</>)       :: d -> d -> d
  82         int         :: Int -> d
  83         integer     :: Integer -> d
  84         char        :: Char    -> d
  85         string      :: String  -> d
  86         text        :: Text.Text  -> d
  87         ltext       :: TL.Text -> d
  88         catH        :: Foldable f => f d -> d
  89         catV        :: Foldable f => f d -> d
  90         foldrWith   :: Foldable f => (d -> d -> d) -> f d -> d
  91         foldWith    :: Foldable f => (d -> d) -> f d -> d
  92         intercalate :: Foldable f => d -> f d -> d
  93         between     :: d -> d -> d -> d
  94         replicate   :: Int -> d -> d
  95
  96         newline = "\n"
  97         space   = char ' '
  98         x <+> y = x <> space <> y
  99         x </> y = x <> newline <> y
 100         int     = stringH . show
 101         integer = stringH . show
 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         replicate cnt t | cnt <= 0  = empty
 113                         | otherwise = t <> replicate (pred cnt) t
 114
 115 -- * Class 'Indentable'
 116 class Textable d => Indentable d where
 117         -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
 118         align :: d -> d
 119         -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
 120         incrIndent  :: Indent -> d -> d
 121         -- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
 122         withIndent  :: Indent -> d -> d
 123         -- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.
 124         --
 125         -- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.
 126         withNewline :: d -> d -> d
 127         newlineWithoutIndent :: d
 128         newlineWithIndent    :: d
 129         -- | @('column' f)@ write @f@ applied to the current 'Column'.
 130         column :: (Column -> d) -> d
 131         -- | @('indent' f)@ write @f@ applied to the current 'Indent'.
 132         indent :: (Indent -> d) -> d
 133
 134         -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
 135         hang :: Indent -> d -> d
 136         hang ind = align . incrIndent ind
 137
 138         -- | @('endToEndWidth' d f)@ write @d@ then
 139         -- @f@ applied to the difference between
 140         -- the end 'Column' and start 'Column' of @d@.
 141         --
 142         -- Note that @f@ is given the end-to-end width,
 143         -- which is not necessarily the maximal width.
 144         endToEndWidth :: d -> (Column -> d) -> d
 145         endToEndWidth d f = column $ \c1 -> (d <>) $ column $ \c2 -> f $ c2 - c1
 146
 147         -- | @'spaces' ind = 'replicate' ind 'space'@
 148         spaces :: Indent -> d
 149         spaces i = replicate (fromIntegral i) space
 150
 151         -- | @('fill' ind d)@ write @d@,
 152         -- then if @d@ is not wider than @ind@,
 153         -- write the difference with 'spaces'.
 154         fill :: Indent -> d -> d
 155         fill m d =
 156                 endToEndWidth d $ \w ->
 157                         case w`compare`m of
 158                          LT -> spaces $ m - w
 159                          _  -> empty
 160
 161         -- | @('breakableFill' ind d)@ write @d@,
 162         -- then if @d@ is not wider than @ind@, write the difference with 'spaces'
 163         -- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @ind@.
 164         breakableFill :: Indent -> d -> d
 165         breakableFill m d =
 166                 column $ \c ->
 167                 endToEndWidth d $ \w ->
 168                         case w`compare`m of
 169                          LT -> spaces (m - w) <> empty
 170                          EQ -> empty
 171                          GT -> withIndent (c + m) newline
 172
 173 -- * Class 'Breakable'
 174 class (Textable d, Indentable d) => Breakable d where
 175         -- | @('breakable' f)@ write @f@ applied to whether breaks are activated or not.
 176         breakable :: (Maybe Column -> d) -> d
 177         -- | @('withBreakable' b d)@ whether to active breaks or not within @d@.
 178         withBreakable :: Maybe Column -> d -> d
 179         -- | @('ifBreak' onWrap onNoWrap)@
 180         -- write @onWrap@ if @onNoWrap@ leads to a 'Column'
 181         -- greater or equal to the one sets with 'withBreakable',
 182         -- otherwise write @onNoWrap@.
 183         ifBreak :: d -> d -> d
 184         -- | @('breakpoint' onNoBreak onBreak d)@
 185         -- write @onNoBreak@ then @d@ if they fit,
 186         -- @onBreak@ otherwise.
 187         breakpoint :: d -> d -> d -> d
 188
 189         -- | @('breakableEmpty' d)@ write @d@ if it fits, 'newline' then @d@ otherwise.
 190         breakableEmpty :: d -> d
 191         breakableEmpty = breakpoint empty newline
 192
 193         -- | @x '><' y = x '<>' 'breakableEmpty' y@
 194         (><) :: d -> d -> d
 195         x >< y = x <> breakableEmpty y
 196
 197         -- | @('breakableSpace' d)@ write 'space' then @d@ it they fit,
 198         -- 'newline' then @d@ otherwise.
 199         breakableSpace :: d -> d
 200         breakableSpace = breakpoint space newline
 201
 202         -- | @x '>+<' y = x '<>' 'breakableSpace' y@
 203         (>+<) :: d -> d -> d
 204         x >+< y = x <> breakableSpace y
 205
 206         -- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
 207         -- between items of @ds@.
 208         breakableSpaces :: Foldable f => f d -> d
 209         breakableSpaces = foldWith breakableSpace
 210
 211         -- | @('intercalateHorV' sep ds)@
 212         -- write @ds@ with @sep@ intercalated if the whole fits,
 213         -- otherwise write 'align' of @ds@ with 'newline' and @sep@ intercalated.
 214         intercalateHorV :: Foldable f => d -> f d -> d
 215         intercalateHorV sep xs =
 216                 ifBreak
 217                  (align $ foldWith ((newline <> sep) <>) xs)
 218                  (foldWith (sep <>) xs)
 219
 220 -- * Class 'Colorable'
 221 class Colorable d where
 222         -- | @('colorable' f)@ write @f@ applied to whether colors are activated or not.
 223         colorable :: (Bool -> d) -> d
 224         -- | @('withColor' b d)@ whether to active colors or not within @d@.
 225         withColorable :: Bool -> d -> d
 226
 227         reverse :: d -> d
 228
 229         -- Foreground colors
 230         -- Dull
 231         black   :: d -> d
 232         red     :: d -> d
 233         green   :: d -> d
 234         yellow  :: d -> d
 235         blue    :: d -> d
 236         magenta :: d -> d
 237         cyan    :: d -> d
 238         white   :: d -> d
 239
 240         -- Vivid
 241         blacker   :: d -> d
 242         redder    :: d -> d
 243         greener   :: d -> d
 244         yellower  :: d -> d
 245         bluer     :: d -> d
 246         magentaer :: d -> d
 247         cyaner    :: d -> d
 248         whiter    :: d -> d
 249
 250         -- Background colors
 251         -- Dull
 252         onBlack   :: d -> d
 253         onRed     :: d -> d
 254         onGreen   :: d -> d
 255         onYellow  :: d -> d
 256         onBlue    :: d -> d
 257         onMagenta :: d -> d
 258         onCyan    :: d -> d
 259         onWhite   :: d -> d
 260
 261         -- Vivid
 262         onBlacker   :: d -> d
 263         onRedder    :: d -> d
 264         onGreener   :: d -> d
 265         onYellower  :: d -> d
 266         onBluer     :: d -> d
 267         onMagentaer :: d -> d
 268         onCyaner    :: d -> d
 269         onWhiter    :: d -> d
 270
 271         default reverse     :: Colorable (ReprOf d) => Trans d => d -> d
 272         default black       :: Colorable (ReprOf d) => Trans d => d -> d
 273         default red         :: Colorable (ReprOf d) => Trans d => d -> d
 274         default green       :: Colorable (ReprOf d) => Trans d => d -> d
 275         default yellow      :: Colorable (ReprOf d) => Trans d => d -> d
 276         default blue        :: Colorable (ReprOf d) => Trans d => d -> d
 277         default magenta     :: Colorable (ReprOf d) => Trans d => d -> d
 278         default cyan        :: Colorable (ReprOf d) => Trans d => d -> d
 279         default white       :: Colorable (ReprOf d) => Trans d => d -> d
 280         default blacker     :: Colorable (ReprOf d) => Trans d => d -> d
 281         default redder      :: Colorable (ReprOf d) => Trans d => d -> d
 282         default greener     :: Colorable (ReprOf d) => Trans d => d -> d
 283         default yellower    :: Colorable (ReprOf d) => Trans d => d -> d
 284         default bluer       :: Colorable (ReprOf d) => Trans d => d -> d
 285         default magentaer   :: Colorable (ReprOf d) => Trans d => d -> d
 286         default cyaner      :: Colorable (ReprOf d) => Trans d => d -> d
 287         default whiter      :: Colorable (ReprOf d) => Trans d => d -> d
 288         default onBlack     :: Colorable (ReprOf d) => Trans d => d -> d
 289         default onRed       :: Colorable (ReprOf d) => Trans d => d -> d
 290         default onGreen     :: Colorable (ReprOf d) => Trans d => d -> d
 291         default onYellow    :: Colorable (ReprOf d) => Trans d => d -> d
 292         default onBlue      :: Colorable (ReprOf d) => Trans d => d -> d
 293         default onMagenta   :: Colorable (ReprOf d) => Trans d => d -> d
 294         default onCyan      :: Colorable (ReprOf d) => Trans d => d -> d
 295         default onWhite     :: Colorable (ReprOf d) => Trans d => d -> d
 296         default onBlacker   :: Colorable (ReprOf d) => Trans d => d -> d
 297         default onRedder    :: Colorable (ReprOf d) => Trans d => d -> d
 298         default onGreener   :: Colorable (ReprOf d) => Trans d => d -> d
 299         default onYellower  :: Colorable (ReprOf d) => Trans d => d -> d
 300         default onBluer     :: Colorable (ReprOf d) => Trans d => d -> d
 301         default onMagentaer :: Colorable (ReprOf d) => Trans d => d -> d
 302         default onCyaner    :: Colorable (ReprOf d) => Trans d => d -> d
 303         default onWhiter    :: Colorable (ReprOf d) => Trans d => d -> d
 304
 305         reverse     = trans1 reverse
 306         black       = trans1 black
 307         red         = trans1 red
 308         green       = trans1 green
 309         yellow      = trans1 yellow
 310         blue        = trans1 blue
 311         magenta     = trans1 magenta
 312         cyan        = trans1 cyan
 313         white       = trans1 white
 314         blacker     = trans1 blacker
 315         redder      = trans1 redder
 316         greener     = trans1 greener
 317         yellower    = trans1 yellower
 318         bluer       = trans1 bluer
 319         magentaer   = trans1 magentaer
 320         cyaner      = trans1 cyaner
 321         whiter      = trans1 whiter
 322         onBlack     = trans1 onBlack
 323         onRed       = trans1 onRed
 324         onGreen     = trans1 onGreen
 325         onYellow    = trans1 onYellow
 326         onBlue      = trans1 onBlue
 327         onMagenta   = trans1 onMagenta
 328         onCyan      = trans1 onCyan
 329         onWhite     = trans1 onWhite
 330         onBlacker   = trans1 onBlacker
 331         onRedder    = trans1 onRedder
 332         onGreener   = trans1 onGreener
 333         onYellower  = trans1 onYellower
 334         onBluer     = trans1 onBluer
 335         onMagentaer = trans1 onMagentaer
 336         onCyaner    = trans1 onCyaner
 337         onWhiter    = trans1 onWhiter
 338
 339 -- * Class 'Decorable'
 340 class Decorable d where
 341         -- | @('decorable' f)@ write @f@ applied to whether decorations are activated or not.
 342         decorable :: (Bool -> d) -> d
 343         -- | @('withColor' b d)@ whether to active decorations or not within @d@.
 344         withDecorable :: Bool -> d -> d
 345
 346         bold      :: d -> d
 347         underline :: d -> d
 348         italic    :: d -> d
 349         default bold      :: Decorable (ReprOf d) => Trans d => d -> d
 350         default underline :: Decorable (ReprOf d) => Trans d => d -> d
 351         default italic    :: Decorable (ReprOf d) => Trans d => d -> d
 352         bold      = trans1 bold
 353         underline = trans1 underline
 354         italic    = trans1 italic
 355
 356 -- * Class 'Trans'
 357 class Trans tr where
 358         -- | Return the underlying @tr@ of the transformer.
 359         type ReprOf tr :: *
 360
 361         -- | Lift a tr to the transformer's.
 362         trans :: ReprOf tr -> tr
 363         -- | Unlift a tr from the transformer's.
 364         unTrans :: tr -> ReprOf tr
 365
 366         -- | Identity transformation for a unary symantic method.
 367         trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
 368         trans1 f = trans . f . unTrans
 369
 370         -- | Identity transformation for a binary symantic method.
 371         trans2
 372          :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
 373          -> (tr -> tr -> tr)
 374         trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
 375
 376         -- | Identity transformation for a ternary symantic method.
 377         trans3
 378          :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
 379          -> (tr -> tr -> tr -> tr)
 380         trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))
 381
 382 -- | Break a 'String' into lines while preserving all empty lines.
 383 lines :: String -> [String]
 384 lines cs =
 385         case List.break (== '\n') cs of
 386          (chunk, _:rest) -> chunk : lines rest
 387          (chunk, []) -> [chunk]