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