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