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