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