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