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 'PlainText'
  24 -- | Drop 'Colorable16' and 'Decorable'.
  25 newtype PlainText d = PlainText { unPlainText :: d }
  26  deriving (Show)
  27
  28 plainText :: PlainText d -> PlainText d
  29 plainText = id
  30
  31 runPlainText :: PlainText d -> d
  32 runPlainText (PlainText d) = d
  33
  34 instance From Char d => From Char (PlainText d) where
  35         from = PlainText . from
  36 instance From String d => From String (PlainText d) where
  37         from = PlainText . from
  38 instance From Text d => From Text (PlainText d) where
  39         from = PlainText . from
  40 instance From TL.Text d => From TL.Text (PlainText d) where
  41         from = PlainText . from
  42 instance From s (PlainText d) => From (Line s) (PlainText d) where
  43         from = from . unLine
  44 instance From s (PlainText d) => From (Word s) (PlainText d) where
  45         from = from . unWord
  46 instance From String d => IsString (PlainText d) where
  47         fromString = from
  48 instance Semigroup d => Semigroup (PlainText d) where
  49         PlainText x <> PlainText y = PlainText $ (<>) x y
  50 instance Monoid d => Monoid (PlainText d) where
  51         mempty = PlainText mempty
  52         mappend = (<>)
  53 instance Lengthable d => Lengthable (PlainText d) where
  54         -- NOTE: PlainText's Reader can be run with an empty value
  55         -- because all 'SGR' are ignored anyway.
  56         width (PlainText ds) = width ds
  57         nullWidth (PlainText ds) = nullWidth ds
  58 instance Spaceable d => Spaceable (PlainText d) where
  59         newline = PlainText $ newline
  60         space   = PlainText $ space
  61         spaces  = PlainText . spaces
  62 instance Semigroup d => Colorable16 (PlainText d) where
  63         reverse     = plainTextSGR
  64         black       = plainTextSGR
  65         red         = plainTextSGR
  66         green       = plainTextSGR
  67         yellow      = plainTextSGR
  68         blue        = plainTextSGR
  69         magenta     = plainTextSGR
  70         cyan        = plainTextSGR
  71         white       = plainTextSGR
  72         blacker     = plainTextSGR
  73         redder      = plainTextSGR
  74         greener     = plainTextSGR
  75         yellower    = plainTextSGR
  76         bluer       = plainTextSGR
  77         magentaer   = plainTextSGR
  78         cyaner      = plainTextSGR
  79         whiter      = plainTextSGR
  80         onBlack     = plainTextSGR
  81         onRed       = plainTextSGR
  82         onGreen     = plainTextSGR
  83         onYellow    = plainTextSGR
  84         onBlue      = plainTextSGR
  85         onMagenta   = plainTextSGR
  86         onCyan      = plainTextSGR
  87         onWhite     = plainTextSGR
  88         onBlacker   = plainTextSGR
  89         onRedder    = plainTextSGR
  90         onGreener   = plainTextSGR
  91         onYellower  = plainTextSGR
  92         onBluer     = plainTextSGR
  93         onMagentaer = plainTextSGR
  94         onCyaner    = plainTextSGR
  95         onWhiter    = plainTextSGR
  96 instance Semigroup d => Decorable (PlainText d) where
  97         bold      = plainTextSGR
  98         underline = plainTextSGR
  99         italic    = plainTextSGR
 100 instance Justifiable d => Justifiable (PlainText d) where
 101         justify (PlainText d) = PlainText $ justify d
 102 instance Indentable d => Indentable (PlainText d) where
 103         align (PlainText d)          = PlainText $ align d
 104         setIndent  p i (PlainText d) = PlainText $ setIndent  (runPlainText p) i d
 105         incrIndent p i (PlainText d) = PlainText $ incrIndent (runPlainText p) i d
 106         fill w (PlainText d)         = PlainText $ fill w d
 107         fillOrBreak w (PlainText d)  = PlainText $ fillOrBreak w d
 108 instance Listable d => Listable (PlainText d) where
 109         ul ds = PlainText $ ul $ unPlainText <$> ds
 110         ol ds = PlainText $ ol $ unPlainText <$> ds
 111 instance Wrappable d => Wrappable (PlainText d) where
 112         setWidth w (PlainText d) = PlainText $ setWidth w d
 113         breakpoint = PlainText breakpoint
 114         breakspace = PlainText breakspace
 115         endline    = PlainText endline
 116         breakalt (PlainText x) (PlainText y) = PlainText $ breakalt x y
 117
 118 plainTextSGR ::
 119  Semigroup d =>
 120  PlainText d -> PlainText d
 121 plainTextSGR (PlainText d) = PlainText d