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 DocFrom Char d => DocFrom Char (AnsiText d) where
  31         docFrom = AnsiText . return . docFrom
  32 instance DocFrom String d => DocFrom String (AnsiText d) where
  33         docFrom = AnsiText . return . docFrom
  34 instance DocFrom Text d => DocFrom Text (AnsiText d) where
  35         docFrom = AnsiText . return . docFrom
  36 instance DocFrom TL.Text d => DocFrom TL.Text (AnsiText d) where
  37         docFrom = AnsiText . return . docFrom
  38 instance DocFrom s (AnsiText d) => DocFrom (Line s) (AnsiText d) where
  39         docFrom = docFrom . unLine
  40 instance DocFrom s (AnsiText d) => DocFrom (Word s) (AnsiText d) where
  41         docFrom = docFrom . unWord
  42 instance DocFrom String d => IsString (AnsiText d) where
  43         fromString = docFrom
  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         length (AnsiText ds) = length $ runReader ds mempty
  53         nullLength (AnsiText ds) = nullLength $ 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, DocFrom [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, DocFrom [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 => 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 => DocFrom [SGR] d =>
 112  SGR -> AnsiText d -> AnsiText d
 113 ansiTextSGR newSGR (AnsiText d) = AnsiText $ do
 114         oldSGR <- ask
 115         (\m -> docFrom [newSGR] <> m <> docFrom (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 DocFrom Char d => DocFrom Char (PlainText d) where
 129         docFrom = PlainText . docFrom
 130 instance DocFrom String d => DocFrom String (PlainText d) where
 131         docFrom = PlainText . docFrom
 132 instance DocFrom Text d => DocFrom Text (PlainText d) where
 133         docFrom = PlainText . docFrom
 134 instance DocFrom TL.Text d => DocFrom TL.Text (PlainText d) where
 135         docFrom = PlainText . docFrom
 136 instance DocFrom s (PlainText d) => DocFrom (Line s) (PlainText d) where
 137         docFrom = docFrom . unLine
 138 instance DocFrom s (PlainText d) => DocFrom (Word s) (PlainText d) where
 139         docFrom = docFrom . unWord
 140 instance DocFrom String d => IsString (PlainText d) where
 141         fromString = docFrom
 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         length (PlainText ds) = length ds
 151         nullLength (PlainText ds) = nullLength 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, DocFrom [SGR] 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