src/Symantic/Document/Lang.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 module Symantic.Document.Lang 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))