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         endline    = AnsiText $ return endline
 115         breakalt (AnsiText x) (AnsiText y) = AnsiText $ liftA2 breakalt x y
 116
 117 ansiTextSGR ::
 118  Semigroup d => From [SGR] d =>
 119  SGR -> AnsiText d -> AnsiText d
 120 ansiTextSGR newSGR (AnsiText d) = AnsiText $ do
 121         oldSGR <- ask
 122         (\m -> from [newSGR] <> m <> from (Reset:List.reverse oldSGR))
 123          <$> local (newSGR :) d
 124
 125 -- * Type 'PlainText'
 126 -- | Drop 'Colorable16' and 'Decorable'.
 127 newtype PlainText d = PlainText { unPlainText :: d }
 128  deriving (Show)
 129
 130 plainText :: PlainText d -> PlainText d
 131 plainText = id
 132
 133 runPlainText :: PlainText d -> d
 134 runPlainText (PlainText d) = d
 135
 136 instance From Char d => From Char (PlainText d) where
 137         from = PlainText . from
 138 instance From String d => From String (PlainText d) where
 139         from = PlainText . from
 140 instance From Text d => From Text (PlainText d) where
 141         from = PlainText . from
 142 instance From TL.Text d => From TL.Text (PlainText d) where
 143         from = PlainText . from
 144 instance From s (PlainText d) => From (Line s) (PlainText d) where
 145         from = from . unLine
 146 instance From s (PlainText d) => From (Word s) (PlainText d) where
 147         from = from . unWord
 148 instance From String d => IsString (PlainText d) where
 149         fromString = from
 150 instance Semigroup d => Semigroup (PlainText d) where
 151         PlainText x <> PlainText y = PlainText $ (<>) x y
 152 instance Monoid d => Monoid (PlainText d) where
 153         mempty = PlainText mempty
 154         mappend = (<>)
 155 instance Lengthable d => Lengthable (PlainText d) where
 156         -- NOTE: PlainText's Reader can be run with an empty value
 157         -- because all 'SGR' are ignored anyway.
 158         width (PlainText ds) = width ds
 159         nullWidth (PlainText ds) = nullWidth ds
 160 instance Spaceable d => Spaceable (PlainText d) where
 161         newline = PlainText $ newline
 162         space   = PlainText $ space
 163         spaces  = PlainText . spaces
 164 instance Semigroup d => Colorable16 (PlainText d) where
 165         reverse     = plainTextSGR
 166         black       = plainTextSGR
 167         red         = plainTextSGR
 168         green       = plainTextSGR
 169         yellow      = plainTextSGR
 170         blue        = plainTextSGR
 171         magenta     = plainTextSGR
 172         cyan        = plainTextSGR
 173         white       = plainTextSGR
 174         blacker     = plainTextSGR
 175         redder      = plainTextSGR
 176         greener     = plainTextSGR
 177         yellower    = plainTextSGR
 178         bluer       = plainTextSGR
 179         magentaer   = plainTextSGR
 180         cyaner      = plainTextSGR
 181         whiter      = plainTextSGR
 182         onBlack     = plainTextSGR
 183         onRed       = plainTextSGR
 184         onGreen     = plainTextSGR
 185         onYellow    = plainTextSGR
 186         onBlue      = plainTextSGR
 187         onMagenta   = plainTextSGR
 188         onCyan      = plainTextSGR
 189         onWhite     = plainTextSGR
 190         onBlacker   = plainTextSGR
 191         onRedder    = plainTextSGR
 192         onGreener   = plainTextSGR
 193         onYellower  = plainTextSGR
 194         onBluer     = plainTextSGR
 195         onMagentaer = plainTextSGR
 196         onCyaner    = plainTextSGR
 197         onWhiter    = plainTextSGR
 198 instance Semigroup d => Decorable (PlainText d) where
 199         bold      = plainTextSGR
 200         underline = plainTextSGR
 201         italic    = plainTextSGR
 202 instance Justifiable d => Justifiable (PlainText d) where
 203         justify (PlainText d) = PlainText $ justify d
 204 instance Indentable d => Indentable (PlainText d) where
 205         setIndent i (PlainText d)  = PlainText $ setIndent i d
 206         incrIndent i (PlainText d) = PlainText $ incrIndent i d
 207         fill w (PlainText d)       = PlainText $ fill w d
 208         breakfill w (PlainText d)  = PlainText $ breakfill w d
 209         align (PlainText d)        = PlainText $ align d
 210 instance Listable d => Listable (PlainText d) where
 211         ul ds = PlainText $ ul $ unPlainText <$> ds
 212         ol ds = PlainText $ ol $ unPlainText <$> ds
 213 instance Wrappable d => Wrappable (PlainText d) where
 214         setWidth w (PlainText d) = PlainText $ setWidth w d
 215         breakpoint = PlainText breakpoint
 216         breakspace = PlainText breakspace
 217         endline    = PlainText endline
 218         breakalt (PlainText x) (PlainText y) = PlainText $ breakalt x y
 219
 220 plainTextSGR ::
 221  Semigroup d =>
 222  PlainText d -> PlainText d
 223 plainTextSGR (PlainText d) = PlainText d