AnsiText.hs

{-# 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

-- * Type 'AnsiText'
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
	-- NOTE: AnsiText's Reader can be run with an empty value
	-- because all 'SGR' are ignored anyway.
	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

-- * Type 'PlainText'
-- | Drop 'Colorable16' and 'Decorable'.
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
	-- NOTE: PlainText's Reader can be run with an empty value
	-- because all 'SGR' are ignored anyway.
	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