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