Symantic/Document/API.hs

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