src/Symantic/Document/Class.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 module Symantic.Document.Class where
   4
   5 import Control.Applicative (Applicative(..))
   6 import Data.Bool
   7 import Data.Char (Char)
   8 import Data.Eq (Eq(..))
   9 import Data.Foldable (Foldable)
  10 import Data.Function ((.), ($), id, const)
  11 import Data.Functor (Functor(..), (<$>))
  12 import Data.Int (Int)
  13 import Data.Kind (Type)
  14 import Data.Maybe (Maybe(..))
  15 import Data.Monoid (Monoid(..))
  16 import Data.Ord (Ord(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.String (String, IsString(..))
  19 import Data.Text (Text)
  20 import Data.Traversable (Traversable)
  21 import Numeric.Natural (Natural)
  22 import Prelude (Integer, fromIntegral, pred)
  23 import Text.Show (Show(..))
  24 import qualified Data.Foldable as Fold
  25 import qualified Data.List as List
  26 import qualified Data.Text as Text
  27 import qualified Data.Text.Lazy as TL
  28 import qualified Data.Text.Lazy.Builder as TLB
  29 import qualified System.Console.ANSI as ANSI
  30
  31 -- * Helper types
  32 type Column = Natural
  33 type Indent = Column
  34 type Width = Natural
  35 type SGR = ANSI.SGR
  36
  37 -- ** Type 'Line'
  38 newtype Line d = Line d
  39  deriving (Eq,Show)
  40 unLine :: Line d -> d
  41 unLine (Line d) = d
  42
  43 -- ** Type 'Word'
  44 newtype Word d = Word d
  45  deriving (Eq,Show,Semigroup)
  46 unWord :: Word d -> d
  47 unWord (Word d) = d
  48 instance From [SGR] d => From [SGR] (Word d) where
  49   from = Word . from
  50
  51 -- * Class 'From'
  52 class From a d where
  53   from :: a -> d
  54   default from :: From String d => Show a => a -> d
  55   from = from . show
  56 instance From (Line String) d => From Int d where
  57   from = from . Line . show
  58 instance From (Line String) d => From Integer d where
  59   from = from . Line . show
  60 instance From (Line String) d => From Natural d where
  61   from = from . Line . show
  62
  63 -- String
  64 instance From Char String where
  65   from = pure
  66 instance From String String where
  67   from = id
  68 instance From Text String where
  69   from = Text.unpack
  70 instance From TL.Text String where
  71   from = TL.unpack
  72 instance From d String => From (Line d) String where
  73   from = from . unLine
  74 instance From d String => From (Word d) String where
  75   from = from . unWord
  76 instance From [SGR] String where
  77   from = ANSI.setSGRCode
  78
  79 -- Text
  80 instance From Char Text where
  81   from = Text.singleton
  82 instance From String Text where
  83   from = Text.pack
  84 instance From Text Text where
  85   from = id
  86 instance From TL.Text Text where
  87   from = TL.toStrict
  88 instance From d Text => From (Line d) Text where
  89   from = from . unLine
  90 instance From d Text => From (Word d) Text where
  91   from = from . unWord
  92 instance From [SGR] Text where
  93   from = from . ANSI.setSGRCode
  94
  95 -- TL.Text
  96 instance From Char TL.Text where
  97   from = TL.singleton
  98 instance From String TL.Text where
  99   from = TL.pack
 100 instance From Text TL.Text where
 101   from = TL.fromStrict
 102 instance From TL.Text TL.Text where
 103   from = id
 104 instance From d TL.Text => From (Line d) TL.Text where
 105   from = from . unLine
 106 instance From d TL.Text => From (Word d) TL.Text where
 107   from = from . unWord
 108 instance From [SGR] TL.Text where
 109   from = from . ANSI.setSGRCode
 110
 111 -- TLB.Builder
 112 instance From Char TLB.Builder where
 113   from = TLB.singleton
 114 instance From String TLB.Builder where
 115   from = fromString
 116 instance From Text TLB.Builder where
 117   from = TLB.fromText
 118 instance From TL.Text TLB.Builder where
 119   from = TLB.fromLazyText
 120 instance From TLB.Builder TLB.Builder where
 121   from = id
 122 instance From d TLB.Builder => From (Line d) TLB.Builder where
 123   from = from . unLine
 124 instance From d TLB.Builder => From (Word d) TLB.Builder where
 125   from = from . unWord
 126 instance From [SGR] TLB.Builder where
 127   from = from . ANSI.setSGRCode
 128
 129 runTextBuilder :: TLB.Builder -> TL.Text
 130 runTextBuilder = TLB.toLazyText
 131
 132 -- * Class 'Lengthable'
 133 class Lengthable d where
 134   width :: d -> Column
 135   nullWidth :: d -> Bool
 136   nullWidth d = width d == 0
 137 instance Lengthable Char where
 138   width _ = 1
 139   nullWidth = const False
 140 instance Lengthable String where
 141   width = fromIntegral . List.length
 142   nullWidth = Fold.null
 143 instance Lengthable Text.Text where
 144   width = fromIntegral . Text.length
 145   nullWidth = Text.null
 146 instance Lengthable TL.Text where
 147   width = fromIntegral . TL.length
 148   nullWidth = TL.null
 149 instance Lengthable d => Lengthable (Line d) where
 150   width = fromIntegral . width . unLine
 151   nullWidth = nullWidth . unLine
 152 instance Lengthable d => Lengthable (Word d) where
 153   width = fromIntegral . width . unWord
 154   nullWidth = nullWidth . unWord
 155
 156 -- * Class 'Spaceable'
 157 class Monoid d => Spaceable d where
 158   newline :: d
 159   space   :: d
 160   default newline :: Spaceable (UnTrans d) => Trans d => d
 161   default space   :: Spaceable (UnTrans d) => Trans d => d
 162   newline = noTrans newline
 163   space   = noTrans space
 164
 165   -- | @'spaces' ind = 'replicate' ind 'space'@
 166   spaces :: Column -> d
 167   default spaces :: Monoid d => Column -> d
 168   spaces i = replicate (fromIntegral i) space
 169   unlines :: Foldable f => f (Line d) -> d
 170   unlines = Fold.foldr (\(Line x) acc -> x<>newline<>acc) mempty
 171   unwords :: Foldable f => Functor f => f (Word d) -> d
 172   unwords = intercalate space . (unWord <$>)
 173   -- | Like 'unlines' but without the trailing 'newline'.
 174   catLines :: Foldable f => Functor f => f (Line d) -> d
 175   catLines = catV . (unLine <$>)
 176   -- | @x '<+>' y = x '<>' 'space' '<>' y@
 177   (<+>) :: d -> d -> d
 178   -- | @x '</>' y = x '<>' 'newline' '<>' y@
 179   (</>) :: d -> d -> d
 180   x <+> y = x <> space <> y
 181   x </> y = x <> newline <> y
 182   catH :: Foldable f => f d -> d
 183   catV :: Foldable f => f d -> d
 184   catH = Fold.foldr (<>) mempty
 185   catV = intercalate newline
 186 infixr 6 <+>
 187 infixr 6 </>
 188 instance Spaceable String where
 189   newline  = "\n"
 190   space    = " "
 191   spaces n = List.replicate (fromIntegral n) ' '
 192 instance Spaceable Text where
 193   newline  = "\n"
 194   space    = " "
 195   spaces n = Text.replicate (fromIntegral n) " "
 196 instance Spaceable TL.Text where
 197   newline  = "\n"
 198   space    = " "
 199   spaces n = TL.replicate (fromIntegral n) " "
 200 instance Spaceable TLB.Builder where
 201   newline  = TLB.singleton '\n'
 202   space    = TLB.singleton ' '
 203   spaces   = TLB.fromText . spaces
 204
 205 intercalate :: (Foldable f, Monoid d) => d -> f d -> d
 206 intercalate sep ds = if Fold.null ds then mempty else Fold.foldr1 (\x y -> x<>sep<>y) ds
 207
 208 replicate :: Monoid d => Int -> d -> d
 209 replicate cnt t | cnt <= 0  = mempty
 210                 | otherwise = t `mappend` replicate (pred cnt) t
 211
 212 between :: Semigroup d => d -> d -> d -> d
 213 between o c d = o<>d<>c
 214 parens :: Semigroup d => From (Word Char) d => d -> d
 215 parens = between (from (Word '(')) (from (Word ')'))
 216 braces :: Semigroup d => From (Word Char) d => d -> d
 217 braces = between (from (Word '{')) (from (Word '}'))
 218 brackets :: Semigroup d => From (Word Char) d => d -> d
 219 brackets = between (from (Word '[')) (from (Word ']'))
 220 angles :: Semigroup d => From (Word Char) d => d -> d
 221 angles = between (from (Word '<')) (from (Word '>'))
 222
 223 -- * Class 'Splitable'
 224 class (Lengthable d, Monoid d) => Splitable d where
 225   tail  :: d -> Maybe d
 226   break :: (Char -> Bool) -> d -> (d, d)
 227   span :: (Char -> Bool) -> d -> (d, d)
 228   span f = break (not . f)
 229   lines :: d -> [Line d]
 230   words :: d -> [Word d]
 231   linesNoEmpty :: d -> [Line d]
 232   wordsNoEmpty :: d -> [Word d]
 233   lines = (Line <$>) . splitOnChar (== '\n')
 234   words = (Word <$>) . splitOnChar (== ' ')
 235   linesNoEmpty = (Line <$>) . splitOnCharNoEmpty (== '\n')
 236   wordsNoEmpty = (Word <$>) . splitOnCharNoEmpty (== ' ')
 237
 238   splitOnChar :: (Char -> Bool) -> d -> [d]
 239   splitOnChar f d0 =
 240     if nullWidth d0 then [] else go d0
 241     where
 242     go d =
 243       let (l,r) = f`break`d in
 244       l : case tail r of
 245        Nothing -> []
 246        Just rt | nullWidth rt -> [mempty]
 247                | otherwise -> go rt
 248   splitOnCharNoEmpty :: (Char -> Bool) -> d -> [d]
 249   splitOnCharNoEmpty f d =
 250     let (l,r) = f`break`d in
 251     (if nullWidth l then [] else [l]) <>
 252     case tail r of
 253      Nothing -> []
 254      Just rt -> splitOnCharNoEmpty f rt
 255 instance Splitable String where
 256   tail [] = Nothing
 257   tail s = Just $ List.tail s
 258   break = List.break
 259 instance Splitable Text.Text where
 260   tail "" = Nothing
 261   tail s = Just $ Text.tail s
 262   break = Text.break
 263 instance Splitable TL.Text where
 264   tail "" = Nothing
 265   tail s = Just $ TL.tail s
 266   break = TL.break
 267
 268 -- * Class 'Decorable'
 269 class Decorable d where
 270   bold      :: d -> d
 271   underline :: d -> d
 272   italic    :: d -> d
 273   default bold      :: Decorable (UnTrans d) => Trans d => d -> d
 274   default underline :: Decorable (UnTrans d) => Trans d => d -> d
 275   default italic    :: Decorable (UnTrans d) => Trans d => d -> d
 276   bold      = noTrans1 bold
 277   underline = noTrans1 underline
 278   italic    = noTrans1 italic
 279
 280 -- * Class 'Colorable16'
 281 class Colorable16 d where
 282   reverse :: d -> d
 283
 284   -- Foreground colors
 285   -- Dull
 286   black   :: d -> d
 287   red     :: d -> d
 288   green   :: d -> d
 289   yellow  :: d -> d
 290   blue    :: d -> d
 291   magenta :: d -> d
 292   cyan    :: d -> d
 293   white   :: d -> d
 294
 295   -- Vivid
 296   blacker   :: d -> d
 297   redder    :: d -> d
 298   greener   :: d -> d
 299   yellower  :: d -> d
 300   bluer     :: d -> d
 301   magentaer :: d -> d
 302   cyaner    :: d -> d
 303   whiter    :: d -> d
 304
 305   -- Background colors
 306   -- Dull
 307   onBlack   :: d -> d
 308   onRed     :: d -> d
 309   onGreen   :: d -> d
 310   onYellow  :: d -> d
 311   onBlue    :: d -> d
 312   onMagenta :: d -> d
 313   onCyan    :: d -> d
 314   onWhite   :: d -> d
 315
 316   -- Vivid
 317   onBlacker   :: d -> d
 318   onRedder    :: d -> d
 319   onGreener   :: d -> d
 320   onYellower  :: d -> d
 321   onBluer     :: d -> d
 322   onMagentaer :: d -> d
 323   onCyaner    :: d -> d
 324   onWhiter    :: d -> d
 325
 326   default reverse     :: Colorable16 (UnTrans d) => Trans d => d -> d
 327   default black       :: Colorable16 (UnTrans d) => Trans d => d -> d
 328   default red         :: Colorable16 (UnTrans d) => Trans d => d -> d
 329   default green       :: Colorable16 (UnTrans d) => Trans d => d -> d
 330   default yellow      :: Colorable16 (UnTrans d) => Trans d => d -> d
 331   default blue        :: Colorable16 (UnTrans d) => Trans d => d -> d
 332   default magenta     :: Colorable16 (UnTrans d) => Trans d => d -> d
 333   default cyan        :: Colorable16 (UnTrans d) => Trans d => d -> d
 334   default white       :: Colorable16 (UnTrans d) => Trans d => d -> d
 335   default blacker     :: Colorable16 (UnTrans d) => Trans d => d -> d
 336   default redder      :: Colorable16 (UnTrans d) => Trans d => d -> d
 337   default greener     :: Colorable16 (UnTrans d) => Trans d => d -> d
 338   default yellower    :: Colorable16 (UnTrans d) => Trans d => d -> d
 339   default bluer       :: Colorable16 (UnTrans d) => Trans d => d -> d
 340   default magentaer   :: Colorable16 (UnTrans d) => Trans d => d -> d
 341   default cyaner      :: Colorable16 (UnTrans d) => Trans d => d -> d
 342   default whiter      :: Colorable16 (UnTrans d) => Trans d => d -> d
 343   default onBlack     :: Colorable16 (UnTrans d) => Trans d => d -> d
 344   default onRed       :: Colorable16 (UnTrans d) => Trans d => d -> d
 345   default onGreen     :: Colorable16 (UnTrans d) => Trans d => d -> d
 346   default onYellow    :: Colorable16 (UnTrans d) => Trans d => d -> d
 347   default onBlue      :: Colorable16 (UnTrans d) => Trans d => d -> d
 348   default onMagenta   :: Colorable16 (UnTrans d) => Trans d => d -> d
 349   default onCyan      :: Colorable16 (UnTrans d) => Trans d => d -> d
 350   default onWhite     :: Colorable16 (UnTrans d) => Trans d => d -> d
 351   default onBlacker   :: Colorable16 (UnTrans d) => Trans d => d -> d
 352   default onRedder    :: Colorable16 (UnTrans d) => Trans d => d -> d
 353   default onGreener   :: Colorable16 (UnTrans d) => Trans d => d -> d
 354   default onYellower  :: Colorable16 (UnTrans d) => Trans d => d -> d
 355   default onBluer     :: Colorable16 (UnTrans d) => Trans d => d -> d
 356   default onMagentaer :: Colorable16 (UnTrans d) => Trans d => d -> d
 357   default onCyaner    :: Colorable16 (UnTrans d) => Trans d => d -> d
 358   default onWhiter    :: Colorable16 (UnTrans d) => Trans d => d -> d
 359
 360   reverse     = noTrans1 reverse
 361   black       = noTrans1 black
 362   red         = noTrans1 red
 363   green       = noTrans1 green
 364   yellow      = noTrans1 yellow
 365   blue        = noTrans1 blue
 366   magenta     = noTrans1 magenta
 367   cyan        = noTrans1 cyan
 368   white       = noTrans1 white
 369   blacker     = noTrans1 blacker
 370   redder      = noTrans1 redder
 371   greener     = noTrans1 greener
 372   yellower    = noTrans1 yellower
 373   bluer       = noTrans1 bluer
 374   magentaer   = noTrans1 magentaer
 375   cyaner      = noTrans1 cyaner
 376   whiter      = noTrans1 whiter
 377   onBlack     = noTrans1 onBlack
 378   onRed       = noTrans1 onRed
 379   onGreen     = noTrans1 onGreen
 380   onYellow    = noTrans1 onYellow
 381   onBlue      = noTrans1 onBlue
 382   onMagenta   = noTrans1 onMagenta
 383   onCyan      = noTrans1 onCyan
 384   onWhite     = noTrans1 onWhite
 385   onBlacker   = noTrans1 onBlacker
 386   onRedder    = noTrans1 onRedder
 387   onGreener   = noTrans1 onGreener
 388   onYellower  = noTrans1 onYellower
 389   onBluer     = noTrans1 onBluer
 390   onMagentaer = noTrans1 onMagentaer
 391   onCyaner    = noTrans1 onCyaner
 392   onWhiter    = noTrans1 onWhiter
 393
 394 -- | For debugging purposes.
 395 instance Colorable16 String where
 396   reverse     = xmlSGR "reverse"
 397   black       = xmlSGR "black"
 398   red         = xmlSGR "red"
 399   green       = xmlSGR "green"
 400   yellow      = xmlSGR "yellow"
 401   blue        = xmlSGR "blue"
 402   magenta     = xmlSGR "magenta"
 403   cyan        = xmlSGR "cyan"
 404   white       = xmlSGR "white"
 405   blacker     = xmlSGR "blacker"
 406   redder      = xmlSGR "redder"
 407   greener     = xmlSGR "greener"
 408   yellower    = xmlSGR "yellower"
 409   bluer       = xmlSGR "bluer"
 410   magentaer   = xmlSGR "magentaer"
 411   cyaner      = xmlSGR "cyaner"
 412   whiter      = xmlSGR "whiter"
 413   onBlack     = xmlSGR "onBlack"
 414   onRed       = xmlSGR "onRed"
 415   onGreen     = xmlSGR "onGreen"
 416   onYellow    = xmlSGR "onYellow"
 417   onBlue      = xmlSGR "onBlue"
 418   onMagenta   = xmlSGR "onMagenta"
 419   onCyan      = xmlSGR "onCyan"
 420   onWhite     = xmlSGR "onWhite"
 421   onBlacker   = xmlSGR "onBlacker"
 422   onRedder    = xmlSGR "onRedder"
 423   onGreener   = xmlSGR "onGreener"
 424   onYellower  = xmlSGR "onYellower"
 425   onBluer     = xmlSGR "onBluer"
 426   onMagentaer = xmlSGR "onMagentaer"
 427   onCyaner    = xmlSGR "onCyaner"
 428   onWhiter    = xmlSGR "onWhiter"
 429
 430 -- | For debugging purposes.
 431 xmlSGR :: Semigroup d => From String d => String -> d -> d
 432 xmlSGR newSGR s = from ("<"<>newSGR<>">")<>s<>from ("</"<>newSGR<>">")
 433
 434 -- * Class 'Indentable'
 435 class Spaceable d => Indentable d where
 436   -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
 437   align :: d -> d
 438   -- | @('setIndent' p ind d)@ make @d@ uses @ind@ as 'Indent' level.
 439   -- Using @p@ as 'Indent' text.
 440   setIndent :: d -> Indent -> d -> d
 441   -- | @('incrIndent' p ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
 442   -- Appending @p@ to the current 'Indent' text.
 443   incrIndent :: d -> Indent -> d -> d
 444   hang :: Indent -> d -> d
 445   hang ind = align . incrIndent (spaces ind) ind
 446   -- | @('fill' w d)@ write @d@,
 447   -- then if @d@ is not wider than @w@,
 448   -- write the difference with 'spaces'.
 449   fill :: Width -> d -> d
 450   -- | @('fillOrBreak' w d)@ write @d@,
 451   -- then if @d@ is not wider than @w@, write the difference with 'spaces'
 452   -- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @w@.
 453   fillOrBreak :: Width -> d -> d
 454
 455   default align         :: Indentable (UnTrans d) => Trans d => d -> d
 456   default incrIndent    :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
 457   default setIndent     :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
 458   default fill          :: Indentable (UnTrans d) => Trans d => Width -> d -> d
 459   default fillOrBreak   :: Indentable (UnTrans d) => Trans d => Width -> d -> d
 460
 461   align          = noTrans1 align
 462   setIndent  p i = noTrans . setIndent  (unTrans p) i . unTrans
 463   incrIndent p i = noTrans . incrIndent (unTrans p) i . unTrans
 464   fill           = noTrans1 . fill
 465   fillOrBreak    = noTrans1 . fillOrBreak
 466
 467 class Listable d where
 468   ul :: Traversable f => f d -> d
 469   ol :: Traversable f => f d -> d
 470   default ul ::
 471    Listable (UnTrans d) => Trans d =>
 472    Traversable f => f d -> d
 473   default ol ::
 474    Listable (UnTrans d) => Trans d =>
 475    Traversable f => f d -> d
 476   ul ds = noTrans $ ul $ unTrans <$> ds
 477   ol ds = noTrans $ ol $ unTrans <$> ds
 478
 479 -- * Class 'Wrappable'
 480 class Wrappable d where
 481   setWidth :: Maybe Width -> d -> d
 482   -- getWidth :: (Maybe Width -> d) -> d
 483   breakpoint :: d
 484   breakspace :: d
 485   breakalt   :: d -> d -> d
 486   endline    :: d
 487   default breakpoint :: Wrappable (UnTrans d) => Trans d => d
 488   default breakspace :: Wrappable (UnTrans d) => Trans d => d
 489   default breakalt   :: Wrappable (UnTrans d) => Trans d => d -> d -> d
 490   default endline    :: Wrappable (UnTrans d) => Trans d => d
 491   breakpoint = noTrans breakpoint
 492   breakspace = noTrans breakspace
 493   breakalt   = noTrans2 breakalt
 494   endline    = noTrans endline
 495
 496 -- * Class 'Justifiable'
 497 class Justifiable d where
 498   justify :: d -> d
 499
 500 -- * Class 'Trans'
 501 class Trans repr where
 502   -- | Return the underlying @repr@ of the transformer.
 503   type UnTrans repr :: Type
 504
 505   -- | Lift a repr to the transformer's.
 506   noTrans :: UnTrans repr -> repr
 507   -- | Unlift a repr from the transformer's.
 508   unTrans :: repr -> UnTrans repr
 509
 510   -- | Identity transformation for a unary symantic method.
 511   noTrans1 :: (UnTrans repr -> UnTrans repr) -> (repr -> repr)
 512   noTrans1 f = noTrans . f . unTrans
 513
 514   -- | Identity transformation for a binary symantic method.
 515   noTrans2
 516    :: (UnTrans repr -> UnTrans repr -> UnTrans repr)
 517    -> (repr -> repr -> repr)
 518   noTrans2 f a b = noTrans (f (unTrans a) (unTrans b))
 519
 520   -- | Identity transformation for a ternary symantic method.
 521   noTrans3
 522    :: (UnTrans repr -> UnTrans repr -> UnTrans repr -> UnTrans repr)
 523    -> (repr -> repr -> repr -> repr)
 524   noTrans3 f a b c = noTrans (f (unTrans a) (unTrans b) (unTrans c))