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.Functor.Identity (Identity(..))
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
	align (AnsiText d) = AnsiText $ align <$> d
	setIndent p i (AnsiText d) = AnsiText $ ReaderT $ \inh ->
		Identity $
		setIndent
		 (unAnsiText p`runReader`inh) i
		 (runReader d inh)
	incrIndent p i (AnsiText d) = AnsiText $ ReaderT $ \inh ->
		Identity $
		incrIndent
		 (unAnsiText p`runReader`inh) i
		 (runReader d inh)
	fill w (AnsiText d)        = AnsiText $ fill w <$> d
	fillOrBreak w (AnsiText d) = AnsiText $ fillOrBreak w <$> 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
	endline    = AnsiText $ return endline
	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
	align (PlainText d)          = PlainText $ align d
	setIndent  p i (PlainText d) = PlainText $ setIndent  (runPlainText p) i d
	incrIndent p i (PlainText d) = PlainText $ incrIndent (runPlainText p) i d
	fill w (PlainText d)         = PlainText $ fill w d
	fillOrBreak w (PlainText d)  = PlainText $ fillOrBreak w 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
	endline    = PlainText endline
	breakalt (PlainText x) (PlainText y) = PlainText $ breakalt x y

plainTextSGR ::
 Semigroup d =>
 PlainText d -> PlainText d
plainTextSGR (PlainText d) = PlainText d