{-# LANGUAGE UndecidableInstances #-}
module Symantic.Document.AnsiText where

import Control.Applicative (Applicative(..), liftA2)
import Control.Monad (Monad(..))
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 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 }

ansiText :: AnsiText d -> AnsiText d
ansiText = id

runAnsiText :: AnsiText d -> d
runAnsiText (AnsiText d) = (`runReader` []) d

instance DocFrom Char d => DocFrom Char (AnsiText d) where
        docFrom = AnsiText . return . docFrom
instance DocFrom String d => DocFrom String (AnsiText d) where
        docFrom = AnsiText . return . docFrom
instance DocFrom Text d => DocFrom Text (AnsiText d) where
        docFrom = AnsiText . return . docFrom
instance DocFrom TL.Text d => DocFrom TL.Text (AnsiText d) where
        docFrom = AnsiText . return . docFrom
instance DocFrom s (AnsiText d) => DocFrom (Line s) (AnsiText d) where
        docFrom = docFrom . unLine
instance DocFrom s (AnsiText d) => DocFrom (Word s) (AnsiText d) where
        docFrom = docFrom . unWord
instance DocFrom String d => IsString (AnsiText d) where
        fromString = docFrom
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.
        length (AnsiText ds) = length $ runReader ds mempty
        nullLength (AnsiText ds) = nullLength $ 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, DocFrom [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, DocFrom [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 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 => DocFrom [SGR] d =>
 SGR -> AnsiText d -> AnsiText d
ansiTextSGR newSGR (AnsiText d) = AnsiText $ do
        oldSGR <- ask
        (\m -> docFrom [newSGR] <> m <> docFrom (Reset:List.reverse oldSGR))
         <$> local (newSGR :) d

-- * Type 'PlainText'
-- | Drop 'Colorable16' and 'Decorable'.
newtype PlainText d = PlainText { unPlainText :: d }

plainText :: PlainText d -> PlainText d
plainText = id

runPlainText :: PlainText d -> d
runPlainText (PlainText d) = d

instance DocFrom Char d => DocFrom Char (PlainText d) where
        docFrom = PlainText . docFrom
instance DocFrom String d => DocFrom String (PlainText d) where
        docFrom = PlainText . docFrom
instance DocFrom Text d => DocFrom Text (PlainText d) where
        docFrom = PlainText . docFrom
instance DocFrom TL.Text d => DocFrom TL.Text (PlainText d) where
        docFrom = PlainText . docFrom
instance DocFrom s (PlainText d) => DocFrom (Line s) (PlainText d) where
        docFrom = docFrom . unLine
instance DocFrom s (PlainText d) => DocFrom (Word s) (PlainText d) where
        docFrom = docFrom . unWord
instance DocFrom String d => IsString (PlainText d) where
        fromString = docFrom
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.
        length (PlainText ds) = length ds
        nullLength (PlainText ds) = nullLength 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, DocFrom [SGR] 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 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