{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Document.API where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable, foldr, foldr1, null)
import Data.Function ((.), ($), id, const)
import Data.Functor (Functor(..), (<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Numeric.Natural (Natural)
import Prelude (Integer, fromIntegral, pred)
import System.Console.ANSI (SGR, setSGRCode)
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB

-- * Helper types
type Column = Natural
type Indent = Column
type Width = Natural

-- ** Type 'Line'
newtype Line d = Line d
 deriving (Eq,Show)
unLine :: Line d -> d
unLine (Line d) = d

-- ** Type 'Word'
newtype Word d = Word d
 deriving (Eq,Show,Semigroup)
unWord :: Word d -> d
unWord (Word d) = d
instance DocFrom [SGR] d => DocFrom [SGR] (Word d) where
        docFrom = Word . docFrom

-- * Class 'DocFrom'
class DocFrom a d where
        docFrom :: a -> d
        default docFrom :: DocFrom String d => Show a => a -> d
        docFrom = docFrom . show
instance DocFrom (Line String) d => DocFrom Int d where
        docFrom = docFrom . Line . show
instance DocFrom (Line String) d => DocFrom Integer d where
        docFrom = docFrom . Line . show
instance DocFrom (Line String) d => DocFrom Natural d where
        docFrom = docFrom . Line . show

-- String
instance DocFrom Char String where
        docFrom = pure
instance DocFrom String String where
        docFrom = id
instance DocFrom Text String where
        docFrom = Text.unpack
instance DocFrom TL.Text String where
        docFrom = TL.unpack
instance DocFrom d String => DocFrom (Line d) String where
        docFrom = docFrom . unLine
instance DocFrom d String => DocFrom (Word d) String where
        docFrom = docFrom . unWord
instance DocFrom [SGR] String where
        docFrom = setSGRCode

-- Text
instance DocFrom Char Text where
        docFrom = Text.singleton
instance DocFrom String Text where
        docFrom = Text.pack
instance DocFrom Text Text where
        docFrom = id
instance DocFrom TL.Text Text where
        docFrom = TL.toStrict
instance DocFrom d Text => DocFrom (Line d) Text where
        docFrom = docFrom . unLine
instance DocFrom d Text => DocFrom (Word d) Text where
        docFrom = docFrom . unWord
instance DocFrom [SGR] Text where
        docFrom = docFrom . setSGRCode

-- TLB.Builder
instance DocFrom Char TLB.Builder where
        docFrom = TLB.singleton
instance DocFrom String TLB.Builder where
        docFrom = fromString
instance DocFrom Text TLB.Builder where
        docFrom = TLB.fromText
instance DocFrom TL.Text TLB.Builder where
        docFrom = TLB.fromLazyText
instance DocFrom TLB.Builder TLB.Builder where
        docFrom = id
instance DocFrom d TLB.Builder => DocFrom (Line d) TLB.Builder where
        docFrom = docFrom . unLine
instance DocFrom d TLB.Builder => DocFrom (Word d) TLB.Builder where
        docFrom = docFrom . unWord
instance DocFrom [SGR] TLB.Builder where
        docFrom = docFrom . setSGRCode

runTextBuilder :: TLB.Builder -> TL.Text
runTextBuilder = TLB.toLazyText

-- * Class 'Lengthable'
class Lengthable d where
        length :: d -> Column
        nullLength :: d -> Bool
        nullLength d = length d == 0
instance Lengthable Char where
        length _ = 1
        nullLength = const False
instance Lengthable String where
        length = fromIntegral . List.length
        nullLength = null
instance Lengthable Text.Text where
        length = fromIntegral . Text.length
        nullLength = Text.null
instance Lengthable TL.Text where
        length = fromIntegral . TL.length
        nullLength = TL.null
instance Lengthable d => Lengthable (Line d) where
        length = fromIntegral . length . unLine
        nullLength = nullLength . unLine
instance Lengthable d => Lengthable (Word d) where
        length = fromIntegral . length . unWord
        nullLength = nullLength . unWord

-- * Class 'Spaceable'
class Monoid d => Spaceable d where
        newline :: d
        space   :: d
        default newline :: Spaceable (UnTrans d) => Trans d => d
        default space   :: Spaceable (UnTrans d) => Trans d => d
        newline = noTrans newline
        space   = noTrans space

        -- | @'spaces' ind = 'replicate' ind 'space'@
        spaces :: Column -> d
        default spaces :: Monoid d => Column -> d
        spaces i = replicate (fromIntegral i) space
        unlines :: Foldable f => f (Line d) -> d
        unlines = foldr (\(Line x) acc -> x<>newline<>acc) mempty
        unwords :: Foldable f => Functor f => f (Word d) -> d
        unwords = intercalate space . (unWord <$>)
        -- | Like 'unlines' but without the trailing 'newline'.
        catLines :: Foldable f => Functor f => f (Line d) -> d
        catLines = intercalate newline . (unLine <$>)
        -- | @x '<+>' y = x '<>' 'space' '<>' y@
        (<+>) :: d -> d -> d
        -- | @x '</>' y = x '<>' 'newline' '<>' y@
        (</>) :: d -> d -> d
        x <+> y = x <> space <> y
        x </> y = x <> newline <> y
        catH :: Foldable f => f d -> d
        catV :: Foldable f => f d -> d
        catH = foldr (<>) mempty
        catV = intercalate newline
infixr 6 <+>
infixr 6 </>
instance Spaceable String where
        newline    = "\n"
        space      = " "
        spaces n   = List.replicate (fromIntegral n) ' '
instance Spaceable Text where
        newline    = "\n"
        space      = " "
        spaces n   = Text.replicate (fromIntegral n) " "
instance Spaceable TLB.Builder where
        newline    = TLB.singleton '\n'
        space      = TLB.singleton ' '
        spaces     = TLB.fromText . spaces

intercalate :: (Foldable f, Monoid d) => d -> f d -> d
intercalate sep ds = if null ds then mempty else foldr1 (\x y -> x<>sep<>y) ds

replicate :: Monoid d => Int -> d -> d
replicate cnt t | cnt <= 0  = mempty
                | otherwise = t `mappend` replicate (pred cnt) t

between :: Semigroup d => d -> d -> d -> d
between o c d = o<>d<>c
parens :: Semigroup d => DocFrom (Word Char) d => d -> d
parens = between (docFrom (Word '(')) (docFrom (Word ')'))
braces :: Semigroup d => DocFrom (Word Char) d => d -> d
braces = between (docFrom (Word '{')) (docFrom (Word '}'))
brackets :: Semigroup d => DocFrom (Word Char) d => d -> d
brackets = between (docFrom (Word '[')) (docFrom (Word ']'))
angles :: Semigroup d => DocFrom (Word Char) d => d -> d
angles = between (docFrom (Word '<')) (docFrom (Word '>'))

-- * Class 'Splitable'
class (Lengthable d, Monoid d) => Splitable d where
        tail  :: d -> Maybe d
        break :: (Char -> Bool) -> d -> (d, d)
        span :: (Char -> Bool) -> d -> (d, d)
        span f = break (not . f)
        lines :: d -> [Line d]
        words :: d -> [Word d]
        linesNoEmpty :: d -> [Line d]
        wordsNoEmpty :: d -> [Word d]
        lines = (Line <$>) . splitOnChar (== '\n')
        words = (Word <$>) . splitOnChar (== ' ')
        linesNoEmpty = (Line <$>) . splitOnCharNoEmpty (== '\n')
        wordsNoEmpty = (Word <$>) . splitOnCharNoEmpty (== ' ')

        splitOnChar :: (Char -> Bool) -> d -> [d]
        splitOnChar f d0 =
                if nullLength d0 then [] else go d0
                where
                go d =
                        let (l,r) = f`break`d in
                        l : case tail r of
                         Nothing -> []
                         Just rt | nullLength rt -> [mempty]
                                 | otherwise -> go rt
        splitOnCharNoEmpty :: (Char -> Bool) -> d -> [d]
        splitOnCharNoEmpty f d =
                let (l,r) = f`break`d in
                (if nullLength l then [] else [l]) <>
                case tail r of
                 Nothing -> []
                 Just rt -> splitOnCharNoEmpty f rt
instance Splitable String where
        tail [] = Nothing
        tail s = Just $ List.tail s
        break = List.break
instance Splitable Text.Text where
        tail "" = Nothing
        tail s = Just $ Text.tail s
        break = Text.break
instance Splitable TL.Text where
        tail "" = Nothing
        tail s = Just $ TL.tail s
        break = TL.break

-- * Class 'Decorable'
class Decorable d where
        bold      :: d -> d
        underline :: d -> d
        italic    :: d -> d
        default bold      :: Decorable (UnTrans d) => Trans d => d -> d
        default underline :: Decorable (UnTrans d) => Trans d => d -> d
        default italic    :: Decorable (UnTrans d) => Trans d => d -> d
        bold      = noTrans1 bold
        underline = noTrans1 underline
        italic    = noTrans1 italic

-- * Class 'Colorable16'
class Colorable16 d where
        reverse :: d -> d

        -- Foreground colors
        -- Dull
        black   :: d -> d
        red     :: d -> d
        green   :: d -> d
        yellow  :: d -> d
        blue    :: d -> d
        magenta :: d -> d
        cyan    :: d -> d
        white   :: d -> d

        -- Vivid
        blacker   :: d -> d
        redder    :: d -> d
        greener   :: d -> d
        yellower  :: d -> d
        bluer     :: d -> d
        magentaer :: d -> d
        cyaner    :: d -> d
        whiter    :: d -> d

        -- Background colors
        -- Dull
        onBlack   :: d -> d
        onRed     :: d -> d
        onGreen   :: d -> d
        onYellow  :: d -> d
        onBlue    :: d -> d
        onMagenta :: d -> d
        onCyan    :: d -> d
        onWhite   :: d -> d

        -- Vivid
        onBlacker   :: d -> d
        onRedder    :: d -> d
        onGreener   :: d -> d
        onYellower  :: d -> d
        onBluer     :: d -> d
        onMagentaer :: d -> d
        onCyaner    :: d -> d
        onWhiter    :: d -> d

        default reverse     :: Colorable16 (UnTrans d) => Trans d => d -> d
        default black       :: Colorable16 (UnTrans d) => Trans d => d -> d
        default red         :: Colorable16 (UnTrans d) => Trans d => d -> d
        default green       :: Colorable16 (UnTrans d) => Trans d => d -> d
        default yellow      :: Colorable16 (UnTrans d) => Trans d => d -> d
        default blue        :: Colorable16 (UnTrans d) => Trans d => d -> d
        default magenta     :: Colorable16 (UnTrans d) => Trans d => d -> d
        default cyan        :: Colorable16 (UnTrans d) => Trans d => d -> d
        default white       :: Colorable16 (UnTrans d) => Trans d => d -> d
        default blacker     :: Colorable16 (UnTrans d) => Trans d => d -> d
        default redder      :: Colorable16 (UnTrans d) => Trans d => d -> d
        default greener     :: Colorable16 (UnTrans d) => Trans d => d -> d
        default yellower    :: Colorable16 (UnTrans d) => Trans d => d -> d
        default bluer       :: Colorable16 (UnTrans d) => Trans d => d -> d
        default magentaer   :: Colorable16 (UnTrans d) => Trans d => d -> d
        default cyaner      :: Colorable16 (UnTrans d) => Trans d => d -> d
        default whiter      :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onBlack     :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onRed       :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onGreen     :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onYellow    :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onBlue      :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onMagenta   :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onCyan      :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onWhite     :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onBlacker   :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onRedder    :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onGreener   :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onYellower  :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onBluer     :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onMagentaer :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onCyaner    :: Colorable16 (UnTrans d) => Trans d => d -> d
        default onWhiter    :: Colorable16 (UnTrans d) => Trans d => d -> d

        reverse     = noTrans1 reverse
        black       = noTrans1 black
        red         = noTrans1 red
        green       = noTrans1 green
        yellow      = noTrans1 yellow
        blue        = noTrans1 blue
        magenta     = noTrans1 magenta
        cyan        = noTrans1 cyan
        white       = noTrans1 white
        blacker     = noTrans1 blacker
        redder      = noTrans1 redder
        greener     = noTrans1 greener
        yellower    = noTrans1 yellower
        bluer       = noTrans1 bluer
        magentaer   = noTrans1 magentaer
        cyaner      = noTrans1 cyaner
        whiter      = noTrans1 whiter
        onBlack     = noTrans1 onBlack
        onRed       = noTrans1 onRed
        onGreen     = noTrans1 onGreen
        onYellow    = noTrans1 onYellow
        onBlue      = noTrans1 onBlue
        onMagenta   = noTrans1 onMagenta
        onCyan      = noTrans1 onCyan
        onWhite     = noTrans1 onWhite
        onBlacker   = noTrans1 onBlacker
        onRedder    = noTrans1 onRedder
        onGreener   = noTrans1 onGreener
        onYellower  = noTrans1 onYellower
        onBluer     = noTrans1 onBluer
        onMagentaer = noTrans1 onMagentaer
        onCyaner    = noTrans1 onCyaner
        onWhiter    = noTrans1 onWhiter

-- | For debugging purposes.
instance Colorable16 String where
        reverse     = xmlSGR "reverse"
        black       = xmlSGR "black"
        red         = xmlSGR "red"
        green       = xmlSGR "green"
        yellow      = xmlSGR "yellow"
        blue        = xmlSGR "blue"
        magenta     = xmlSGR "magenta"
        cyan        = xmlSGR "cyan"
        white       = xmlSGR "white"
        blacker     = xmlSGR "blacker"
        redder      = xmlSGR "redder"
        greener     = xmlSGR "greener"
        yellower    = xmlSGR "yellower"
        bluer       = xmlSGR "bluer"
        magentaer   = xmlSGR "magentaer"
        cyaner      = xmlSGR "cyaner"
        whiter      = xmlSGR "whiter"
        onBlack     = xmlSGR "onBlack"
        onRed       = xmlSGR "onRed"
        onGreen     = xmlSGR "onGreen"
        onYellow    = xmlSGR "onYellow"
        onBlue      = xmlSGR "onBlue"
        onMagenta   = xmlSGR "onMagenta"
        onCyan      = xmlSGR "onCyan"
        onWhite     = xmlSGR "onWhite"
        onBlacker   = xmlSGR "onBlacker"
        onRedder    = xmlSGR "onRedder"
        onGreener   = xmlSGR "onGreener"
        onYellower  = xmlSGR "onYellower"
        onBluer     = xmlSGR "onBluer"
        onMagentaer = xmlSGR "onMagentaer"
        onCyaner    = xmlSGR "onCyaner"
        onWhiter    = xmlSGR "onWhiter"

-- | For debugging purposes.
xmlSGR :: Semigroup d => DocFrom String d => String -> d -> d
xmlSGR newSGR s = docFrom ("<"<>newSGR<>">")<>s<>docFrom ("</"<>newSGR<>">")

-- * Class 'Indentable'
class Spaceable d => Indentable d where
        -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
        align :: d -> d
        -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
        incrIndent :: Indent -> d -> d
        -- | @('setIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
        setIndent :: Indent -> d -> d
        -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
        hang :: Indent -> d -> d
        hang ind = align . incrIndent ind
        -- | @('fill' w d)@ write @d@,
        -- then if @d@ is not wider than @w@,
        -- write the difference with 'spaces'.
        fill :: Width -> d -> d
        -- | @('breakfill' w d)@ write @d@,
        -- then if @d@ is not wider than @w@, write the difference with 'spaces'
        -- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @w@.
        breakfill :: Width -> d -> d

        default align      :: Indentable (UnTrans d) => Trans d => d -> d
        default incrIndent :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
        default setIndent  :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
        default fill       :: Indentable (UnTrans d) => Trans d => Width -> d -> d
        default breakfill  :: Indentable (UnTrans d) => Trans d => Width -> d -> d

        align      = noTrans1 align
        incrIndent = noTrans1 . incrIndent
        setIndent  = noTrans1 . setIndent
        fill       = noTrans1 . fill
        breakfill  = noTrans1 . breakfill

-- * Class 'Wrappable'
class Wrappable d where
        setWidth :: Maybe Width -> d -> d
        -- getWidth :: (Maybe Width -> d) -> d
        breakpoint :: d
        breakspace :: d
        breakalt   :: d -> d -> d
        default breakpoint :: Wrappable (UnTrans d) => Trans d => d
        default breakspace :: Wrappable (UnTrans d) => Trans d => d
        default breakalt   :: Wrappable (UnTrans d) => Trans d => d -> d -> d
        breakpoint = noTrans breakpoint
        breakspace = noTrans breakspace
        breakalt   = noTrans2 breakalt

-- * Class 'Justifiable'
class Justifiable d where
        justify :: d -> d

-- * Class 'Trans'
class Trans repr where
        -- | Return the underlying @repr@ of the transformer.
        type UnTrans repr :: *

        -- | Lift a repr to the transformer's.
        noTrans :: UnTrans repr -> repr
        -- | Unlift a repr from the transformer's.
        unTrans :: repr -> UnTrans repr

        -- | Identity transformation for a unary symantic method.
        noTrans1 :: (UnTrans repr -> UnTrans repr) -> (repr -> repr)
        noTrans1 f = noTrans . f . unTrans

        -- | Identity transformation for a binary symantic method.
        noTrans2
         :: (UnTrans repr -> UnTrans repr -> UnTrans repr)
         -> (repr -> repr -> repr)
        noTrans2 f a b = noTrans (f (unTrans a) (unTrans b))

        -- | Identity transformation for a ternary symantic method.
        noTrans3
         :: (UnTrans repr -> UnTrans repr -> UnTrans repr -> UnTrans repr)
         -> (repr -> repr -> repr -> repr)
        noTrans3 f a b c = noTrans (f (unTrans a) (unTrans b) (unTrans c))