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