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