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