Symantic/Document/AnsiText.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 module Symantic.Document.AnsiText where
   3
   4 import Control.Applicative (Applicative(..), liftA2)
   5 import Control.Monad (Monad(..))
   6 import Control.Monad.Trans.Reader
   7 import Data.Bool
   8 import Data.Char (Char)
   9 import Data.Function (($), (.), id)
  10 import Data.Functor ((<$>))
  11 import Data.Monoid (Monoid(..))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.String (String, IsString(..))
  14 import Data.Text (Text)
  15 import System.Console.ANSI
  16 import qualified Data.List as List
  17 import qualified Data.Text.Lazy as TL
  18
  19 import Symantic.Document.API
  20
  21 -- * Type 'AnsiText'
  22 newtype AnsiText d = AnsiText { unAnsiText :: Reader [SGR] d }
  23
  24 ansiText :: AnsiText d -> AnsiText d
  25 ansiText = id
  26
  27 runAnsiText :: AnsiText d -> d
  28 runAnsiText (AnsiText d) = (`runReader` []) d
  29
  30 instance From Char d => From Char (AnsiText d) where
  31         from = AnsiText . return . from
  32 instance From String d => From String (AnsiText d) where
  33         from = AnsiText . return . from
  34 instance From Text d => From Text (AnsiText d) where
  35         from = AnsiText . return . from
  36 instance From TL.Text d => From TL.Text (AnsiText d) where
  37         from = AnsiText . return . from
  38 instance From s (AnsiText d) => From (Line s) (AnsiText d) where
  39         from = from . unLine
  40 instance From s (AnsiText d) => From (Word s) (AnsiText d) where
  41         from = from . unWord
  42 instance From String d => IsString (AnsiText d) where
  43         fromString = from
  44 instance Semigroup d => Semigroup (AnsiText d) where
  45         AnsiText x <> AnsiText y = AnsiText $ liftA2 (<>) x y
  46 instance Monoid d => Monoid (AnsiText d) where
  47         mempty = AnsiText (return mempty)
  48         mappend = (<>)
  49 instance Lengthable d => Lengthable (AnsiText d) where
  50         -- NOTE: AnsiText's Reader can be run with an empty value
  51         -- because all 'SGR' are ignored anyway.
  52         width (AnsiText ds) = width $ runReader ds mempty
  53         nullWidth (AnsiText ds) = nullWidth $ runReader ds mempty
  54 instance Spaceable d => Spaceable (AnsiText d) where
  55         newline = AnsiText $ return newline
  56         space   = AnsiText $ return space
  57         spaces  = AnsiText . return . spaces
  58 instance (Semigroup d, From [SGR] d) => Colorable16 (AnsiText d) where
  59         reverse     = ansiTextSGR $ SetSwapForegroundBackground True
  60         black       = ansiTextSGR $ SetColor Foreground Dull  Black
  61         red         = ansiTextSGR $ SetColor Foreground Dull  Red
  62         green       = ansiTextSGR $ SetColor Foreground Dull  Green
  63         yellow      = ansiTextSGR $ SetColor Foreground Dull  Yellow
  64         blue        = ansiTextSGR $ SetColor Foreground Dull  Blue
  65         magenta     = ansiTextSGR $ SetColor Foreground Dull  Magenta
  66         cyan        = ansiTextSGR $ SetColor Foreground Dull  Cyan
  67         white       = ansiTextSGR $ SetColor Foreground Dull  White
  68         blacker     = ansiTextSGR $ SetColor Foreground Vivid Black
  69         redder      = ansiTextSGR $ SetColor Foreground Vivid Red
  70         greener     = ansiTextSGR $ SetColor Foreground Vivid Green
  71         yellower    = ansiTextSGR $ SetColor Foreground Vivid Yellow
  72         bluer       = ansiTextSGR $ SetColor Foreground Vivid Blue
  73         magentaer   = ansiTextSGR $ SetColor Foreground Vivid Magenta
  74         cyaner      = ansiTextSGR $ SetColor Foreground Vivid Cyan
  75         whiter      = ansiTextSGR $ SetColor Foreground Vivid White
  76         onBlack     = ansiTextSGR $ SetColor Background Dull  Black
  77         onRed       = ansiTextSGR $ SetColor Background Dull  Red
  78         onGreen     = ansiTextSGR $ SetColor Background Dull  Green
  79         onYellow    = ansiTextSGR $ SetColor Background Dull  Yellow
  80         onBlue      = ansiTextSGR $ SetColor Background Dull  Blue
  81         onMagenta   = ansiTextSGR $ SetColor Background Dull  Magenta
  82         onCyan      = ansiTextSGR $ SetColor Background Dull  Cyan
  83         onWhite     = ansiTextSGR $ SetColor Background Dull  White
  84         onBlacker   = ansiTextSGR $ SetColor Background Vivid Black
  85         onRedder    = ansiTextSGR $ SetColor Background Vivid Red
  86         onGreener   = ansiTextSGR $ SetColor Background Vivid Green
  87         onYellower  = ansiTextSGR $ SetColor Background Vivid Yellow
  88         onBluer     = ansiTextSGR $ SetColor Background Vivid Blue
  89         onMagentaer = ansiTextSGR $ SetColor Background Vivid Magenta
  90         onCyaner    = ansiTextSGR $ SetColor Background Vivid Cyan
  91         onWhiter    = ansiTextSGR $ SetColor Background Vivid White
  92 instance (Semigroup d, From [SGR] d) => Decorable (AnsiText d) where
  93         bold      = ansiTextSGR $ SetConsoleIntensity BoldIntensity
  94         underline = ansiTextSGR $ SetUnderlining SingleUnderline
  95         italic    = ansiTextSGR $ SetItalicized True
  96 instance Justifiable d => Justifiable (AnsiText d) where
  97         justify (AnsiText d) = AnsiText $ justify <$> d
  98 instance (Indentable d, From Char d) => Indentable (AnsiText d) where
  99         setIndent i (AnsiText d)  = AnsiText $ setIndent i <$> d
 100         incrIndent i (AnsiText d) = AnsiText $ incrIndent i <$> d
 101         fill w (AnsiText d)       = AnsiText $ fill w <$> d
 102         breakfill w (AnsiText d)  = AnsiText $ breakfill w <$> d
 103         align (AnsiText d)        = AnsiText $ align <$> d
 104 instance Wrappable d => Wrappable (AnsiText d) where
 105         setWidth w (AnsiText d) = AnsiText $ setWidth w <$> d
 106         breakpoint = AnsiText $ return breakpoint
 107         breakspace = AnsiText $ return breakspace
 108         breakalt (AnsiText x) (AnsiText y) = AnsiText $ liftA2 breakalt x y
 109
 110 ansiTextSGR ::
 111  Semigroup d => From [SGR] d =>
 112  SGR -> AnsiText d -> AnsiText d
 113 ansiTextSGR newSGR (AnsiText d) = AnsiText $ do
 114         oldSGR <- ask
 115         (\m -> from [newSGR] <> m <> from (Reset:List.reverse oldSGR))
 116          <$> local (newSGR :) d
 117
 118 -- * Type 'PlainText'
 119 -- | Drop 'Colorable16' and 'Decorable'.
 120 newtype PlainText d = PlainText { unPlainText :: d }
 121
 122 plainText :: PlainText d -> PlainText d
 123 plainText = id
 124
 125 runPlainText :: PlainText d -> d
 126 runPlainText (PlainText d) = d
 127
 128 instance From Char d => From Char (PlainText d) where
 129         from = PlainText . from
 130 instance From String d => From String (PlainText d) where
 131         from = PlainText . from
 132 instance From Text d => From Text (PlainText d) where
 133         from = PlainText . from
 134 instance From TL.Text d => From TL.Text (PlainText d) where
 135         from = PlainText . from
 136 instance From s (PlainText d) => From (Line s) (PlainText d) where
 137         from = from . unLine
 138 instance From s (PlainText d) => From (Word s) (PlainText d) where
 139         from = from . unWord
 140 instance From String d => IsString (PlainText d) where
 141         fromString = from
 142 instance Semigroup d => Semigroup (PlainText d) where
 143         PlainText x <> PlainText y = PlainText $ (<>) x y
 144 instance Monoid d => Monoid (PlainText d) where
 145         mempty = PlainText mempty
 146         mappend = (<>)
 147 instance Lengthable d => Lengthable (PlainText d) where
 148         -- NOTE: PlainText's Reader can be run with an empty value
 149         -- because all 'SGR' are ignored anyway.
 150         width (PlainText ds) = width ds
 151         nullWidth (PlainText ds) = nullWidth ds
 152 instance Spaceable d => Spaceable (PlainText d) where
 153         newline = PlainText $ newline
 154         space   = PlainText $ space
 155         spaces  = PlainText . spaces
 156 instance Semigroup d => Colorable16 (PlainText d) where
 157         reverse     = plainTextSGR
 158         black       = plainTextSGR
 159         red         = plainTextSGR
 160         green       = plainTextSGR
 161         yellow      = plainTextSGR
 162         blue        = plainTextSGR
 163         magenta     = plainTextSGR
 164         cyan        = plainTextSGR
 165         white       = plainTextSGR
 166         blacker     = plainTextSGR
 167         redder      = plainTextSGR
 168         greener     = plainTextSGR
 169         yellower    = plainTextSGR
 170         bluer       = plainTextSGR
 171         magentaer   = plainTextSGR
 172         cyaner      = plainTextSGR
 173         whiter      = plainTextSGR
 174         onBlack     = plainTextSGR
 175         onRed       = plainTextSGR
 176         onGreen     = plainTextSGR
 177         onYellow    = plainTextSGR
 178         onBlue      = plainTextSGR
 179         onMagenta   = plainTextSGR
 180         onCyan      = plainTextSGR
 181         onWhite     = plainTextSGR
 182         onBlacker   = plainTextSGR
 183         onRedder    = plainTextSGR
 184         onGreener   = plainTextSGR
 185         onYellower  = plainTextSGR
 186         onBluer     = plainTextSGR
 187         onMagentaer = plainTextSGR
 188         onCyaner    = plainTextSGR
 189         onWhiter    = plainTextSGR
 190 instance Semigroup d => Decorable (PlainText d) where
 191         bold      = plainTextSGR
 192         underline = plainTextSGR
 193         italic    = plainTextSGR
 194 instance Justifiable d => Justifiable (PlainText d) where
 195         justify (PlainText d) = PlainText $ justify d
 196 instance Indentable d => Indentable (PlainText d) where
 197         setIndent i (PlainText d)  = PlainText $ setIndent i d
 198         incrIndent i (PlainText d) = PlainText $ incrIndent i d
 199         fill w (PlainText d)       = PlainText $ fill w d
 200         breakfill w (PlainText d)  = PlainText $ breakfill w d
 201         align (PlainText d)        = PlainText $ align d
 202 instance Wrappable d => Wrappable (PlainText d) where
 203         setWidth w (PlainText d) = PlainText $ setWidth w d
 204         breakpoint = PlainText breakpoint
 205         breakspace = PlainText breakspace
 206         breakalt (PlainText x) (PlainText y) = PlainText $ breakalt x y
 207
 208 plainTextSGR ::
 209  Semigroup d =>
 210  PlainText d -> PlainText d
 211 plainTextSGR (PlainText d) = PlainText d