{-# LANGUAGE UndecidableInstances #-}
module Symantic.Document.AnsiText where
import Control.Applicative (Applicative(..), liftA2)
import Control.Monad (Monad(..), sequence)
import Control.Monad.Trans.Reader
import Data.Bool
import Data.Char (Char)
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import System.Console.ANSI
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import Symantic.Document.API
newtype AnsiText d = AnsiText { unAnsiText :: Reader [SGR] d }
instance Show d => Show (AnsiText d) where
show (AnsiText d) = show $ runReader d []
ansiText :: AnsiText d -> AnsiText d
ansiText = id
runAnsiText :: AnsiText d -> d
runAnsiText (AnsiText d) = (`runReader` []) d
instance From Char d => From Char (AnsiText d) where
from = AnsiText . return . from
instance From String d => From String (AnsiText d) where
from = AnsiText . return . from
instance From Text d => From Text (AnsiText d) where
from = AnsiText . return . from
instance From TL.Text d => From TL.Text (AnsiText d) where
from = AnsiText . return . from
instance From s (AnsiText d) => From (Line s) (AnsiText d) where
from = from . unLine
instance From s (AnsiText d) => From (Word s) (AnsiText d) where
from = from . unWord
instance From String d => IsString (AnsiText d) where
fromString = from
instance Semigroup d => Semigroup (AnsiText d) where
AnsiText x <> AnsiText y = AnsiText $ liftA2 (<>) x y
instance Monoid d => Monoid (AnsiText d) where
mempty = AnsiText (return mempty)
mappend = (<>)
instance Lengthable d => Lengthable (AnsiText d) where
width (AnsiText ds) = width $ runReader ds mempty
nullWidth (AnsiText ds) = nullWidth $ runReader ds mempty
instance Spaceable d => Spaceable (AnsiText d) where
newline = AnsiText $ return newline
space = AnsiText $ return space
spaces = AnsiText . return . spaces
instance (Semigroup d, From [SGR] d) => Colorable16 (AnsiText d) where
reverse = ansiTextSGR $ SetSwapForegroundBackground True
black = ansiTextSGR $ SetColor Foreground Dull Black
red = ansiTextSGR $ SetColor Foreground Dull Red
green = ansiTextSGR $ SetColor Foreground Dull Green
yellow = ansiTextSGR $ SetColor Foreground Dull Yellow
blue = ansiTextSGR $ SetColor Foreground Dull Blue
magenta = ansiTextSGR $ SetColor Foreground Dull Magenta
cyan = ansiTextSGR $ SetColor Foreground Dull Cyan
white = ansiTextSGR $ SetColor Foreground Dull White
blacker = ansiTextSGR $ SetColor Foreground Vivid Black
redder = ansiTextSGR $ SetColor Foreground Vivid Red
greener = ansiTextSGR $ SetColor Foreground Vivid Green
yellower = ansiTextSGR $ SetColor Foreground Vivid Yellow
bluer = ansiTextSGR $ SetColor Foreground Vivid Blue
magentaer = ansiTextSGR $ SetColor Foreground Vivid Magenta
cyaner = ansiTextSGR $ SetColor Foreground Vivid Cyan
whiter = ansiTextSGR $ SetColor Foreground Vivid White
onBlack = ansiTextSGR $ SetColor Background Dull Black
onRed = ansiTextSGR $ SetColor Background Dull Red
onGreen = ansiTextSGR $ SetColor Background Dull Green
onYellow = ansiTextSGR $ SetColor Background Dull Yellow
onBlue = ansiTextSGR $ SetColor Background Dull Blue
onMagenta = ansiTextSGR $ SetColor Background Dull Magenta
onCyan = ansiTextSGR $ SetColor Background Dull Cyan
onWhite = ansiTextSGR $ SetColor Background Dull White
onBlacker = ansiTextSGR $ SetColor Background Vivid Black
onRedder = ansiTextSGR $ SetColor Background Vivid Red
onGreener = ansiTextSGR $ SetColor Background Vivid Green
onYellower = ansiTextSGR $ SetColor Background Vivid Yellow
onBluer = ansiTextSGR $ SetColor Background Vivid Blue
onMagentaer = ansiTextSGR $ SetColor Background Vivid Magenta
onCyaner = ansiTextSGR $ SetColor Background Vivid Cyan
onWhiter = ansiTextSGR $ SetColor Background Vivid White
instance (Semigroup d, From [SGR] d) => Decorable (AnsiText d) where
bold = ansiTextSGR $ SetConsoleIntensity BoldIntensity
underline = ansiTextSGR $ SetUnderlining SingleUnderline
italic = ansiTextSGR $ SetItalicized True
instance Justifiable d => Justifiable (AnsiText d) where
justify (AnsiText d) = AnsiText $ justify <$> d
instance Indentable d => Indentable (AnsiText d) where
setIndent i (AnsiText d) = AnsiText $ setIndent i <$> d
incrIndent i (AnsiText d) = AnsiText $ incrIndent i <$> d
fill w (AnsiText d) = AnsiText $ fill w <$> d
breakfill w (AnsiText d) = AnsiText $ breakfill w <$> d
align (AnsiText d) = AnsiText $ align <$> d
instance Listable d => Listable (AnsiText d) where
ul ds = AnsiText $ (ul <$>) $ sequence $ unAnsiText <$> ds
ol ds = AnsiText $ (ol <$>) $ sequence $ unAnsiText <$> ds
instance Wrappable d => Wrappable (AnsiText d) where
setWidth w (AnsiText d) = AnsiText $ setWidth w <$> d
breakpoint = AnsiText $ return breakpoint
breakspace = AnsiText $ return breakspace
breakalt (AnsiText x) (AnsiText y) = AnsiText $ liftA2 breakalt x y
ansiTextSGR ::
Semigroup d => From [SGR] d =>
SGR -> AnsiText d -> AnsiText d
ansiTextSGR newSGR (AnsiText d) = AnsiText $ do
oldSGR <- ask
(\m -> from [newSGR] <> m <> from (Reset:List.reverse oldSGR))
<$> local (newSGR :) d
newtype PlainText d = PlainText { unPlainText :: d }
deriving (Show)
plainText :: PlainText d -> PlainText d
plainText = id
runPlainText :: PlainText d -> d
runPlainText (PlainText d) = d
instance From Char d => From Char (PlainText d) where
from = PlainText . from
instance From String d => From String (PlainText d) where
from = PlainText . from
instance From Text d => From Text (PlainText d) where
from = PlainText . from
instance From TL.Text d => From TL.Text (PlainText d) where
from = PlainText . from
instance From s (PlainText d) => From (Line s) (PlainText d) where
from = from . unLine
instance From s (PlainText d) => From (Word s) (PlainText d) where
from = from . unWord
instance From String d => IsString (PlainText d) where
fromString = from
instance Semigroup d => Semigroup (PlainText d) where
PlainText x <> PlainText y = PlainText $ (<>) x y
instance Monoid d => Monoid (PlainText d) where
mempty = PlainText mempty
mappend = (<>)
instance Lengthable d => Lengthable (PlainText d) where
width (PlainText ds) = width ds
nullWidth (PlainText ds) = nullWidth ds
instance Spaceable d => Spaceable (PlainText d) where
newline = PlainText $ newline
space = PlainText $ space
spaces = PlainText . spaces
instance Semigroup d => Colorable16 (PlainText d) where
reverse = plainTextSGR
black = plainTextSGR
red = plainTextSGR
green = plainTextSGR
yellow = plainTextSGR
blue = plainTextSGR
magenta = plainTextSGR
cyan = plainTextSGR
white = plainTextSGR
blacker = plainTextSGR
redder = plainTextSGR
greener = plainTextSGR
yellower = plainTextSGR
bluer = plainTextSGR
magentaer = plainTextSGR
cyaner = plainTextSGR
whiter = plainTextSGR
onBlack = plainTextSGR
onRed = plainTextSGR
onGreen = plainTextSGR
onYellow = plainTextSGR
onBlue = plainTextSGR
onMagenta = plainTextSGR
onCyan = plainTextSGR
onWhite = plainTextSGR
onBlacker = plainTextSGR
onRedder = plainTextSGR
onGreener = plainTextSGR
onYellower = plainTextSGR
onBluer = plainTextSGR
onMagentaer = plainTextSGR
onCyaner = plainTextSGR
onWhiter = plainTextSGR
instance Semigroup d => Decorable (PlainText d) where
bold = plainTextSGR
underline = plainTextSGR
italic = plainTextSGR
instance Justifiable d => Justifiable (PlainText d) where
justify (PlainText d) = PlainText $ justify d
instance Indentable d => Indentable (PlainText d) where
setIndent i (PlainText d) = PlainText $ setIndent i d
incrIndent i (PlainText d) = PlainText $ incrIndent i d
fill w (PlainText d) = PlainText $ fill w d
breakfill w (PlainText d) = PlainText $ breakfill w d
align (PlainText d) = PlainText $ align d
instance Listable d => Listable (PlainText d) where
ul ds = PlainText $ ul $ unPlainText <$> ds
ol ds = PlainText $ ol $ unPlainText <$> ds
instance Wrappable d => Wrappable (PlainText d) where
setWidth w (PlainText d) = PlainText $ setWidth w d
breakpoint = PlainText breakpoint
breakspace = PlainText breakspace
breakalt (PlainText x) (PlainText y) = PlainText $ breakalt x y
plainTextSGR ::
Semigroup d =>
PlainText d -> PlainText d
plainTextSGR (PlainText d) = PlainText d