{-# 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)
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 Data.Traversable (Traversable)
import Numeric.Natural (Natural)
import Prelude (Integer, fromIntegral, pred)
import System.Console.ANSI (SGR, setSGRCode)
import Text.Show (Show(..))
import qualified Data.Foldable as Fold
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 From [SGR] d => From [SGR] (Word d) where
        from = Word . from

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

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

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

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

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

-- * Class 'Lengthable'
class Lengthable d where
        width :: d -> Column
        nullWidth :: d -> Bool
        nullWidth d = width d == 0
instance Lengthable Char where
        width _ = 1
        nullWidth = const False
instance Lengthable String where
        width = fromIntegral . List.length
        nullWidth = Fold.null
instance Lengthable Text.Text where
        width = fromIntegral . Text.length
        nullWidth = Text.null
instance Lengthable TL.Text where
        width = fromIntegral . TL.length
        nullWidth = TL.null
instance Lengthable d => Lengthable (Line d) where
        width = fromIntegral . width . unLine
        nullWidth = nullWidth . unLine
instance Lengthable d => Lengthable (Word d) where
        width = fromIntegral . width . unWord
        nullWidth = nullWidth . 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 = Fold.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 = catV . (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 = Fold.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 Fold.null ds then mempty else Fold.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 => From (Word Char) d => d -> d
parens = between (from (Word '(')) (from (Word ')'))
braces :: Semigroup d => From (Word Char) d => d -> d
braces = between (from (Word '{')) (from (Word '}'))
brackets :: Semigroup d => From (Word Char) d => d -> d
brackets = between (from (Word '[')) (from (Word ']'))
angles :: Semigroup d => From (Word Char) d => d -> d
angles = between (from (Word '<')) (from (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 nullWidth d0 then [] else go d0
                where
                go d =
                        let (l,r) = f`break`d in
                        l : case tail r of
                         Nothing -> []
                         Just rt | nullWidth rt -> [mempty]
                                 | otherwise -> go rt
        splitOnCharNoEmpty :: (Char -> Bool) -> d -> [d]
        splitOnCharNoEmpty f d =
                let (l,r) = f`break`d in
                (if nullWidth 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 => From String d => String -> d -> d
xmlSGR newSGR s = from ("<"<>newSGR<>">")<>s<>from ("</"<>newSGR<>">")

-- * Class 'Indentable'
class Spaceable d => Indentable d where
        -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
        align :: d -> d
        -- | @('setIndent' p ind d)@ make @d@ uses @ind@ as 'Indent' level.
        -- Using @p@ as 'Indent' text.
        setIndent :: d -> Indent -> d -> d
        -- | @('incrIndent' p ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
        -- Appending @p@ to the current 'Indent' text.
        incrIndent :: d -> Indent -> d -> d
        hang :: Indent -> d -> d
        hang ind = align . incrIndent (spaces ind) ind
        -- | @('fill' w d)@ write @d@,
        -- then if @d@ is not wider than @w@,
        -- write the difference with 'spaces'.
        fill :: Width -> d -> d
        -- | @('fillOrBreak' 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@.
        fillOrBreak :: Width -> d -> d

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

        align          = noTrans1 align
        setIndent  p i = noTrans . setIndent  (unTrans p) i . unTrans
        incrIndent p i = noTrans . incrIndent (unTrans p) i . unTrans
        fill           = noTrans1 . fill
        fillOrBreak    = noTrans1 . fillOrBreak

class Listable d where
        ul :: Traversable f => f d -> d
        ol :: Traversable f => f d -> d
        default ul ::
         Listable (UnTrans d) => Trans d =>
         Traversable f => f d -> d
        default ol ::
         Listable (UnTrans d) => Trans d =>
         Traversable f => f d -> d
        ul ds = noTrans $ ul $ unTrans <$> ds
        ol ds = noTrans $ ol $ unTrans <$> ds

-- * Class 'Wrappable'
class Wrappable d where
        setWidth :: Maybe Width -> d -> d
        -- getWidth :: (Maybe Width -> d) -> d
        breakpoint :: d
        breakspace :: d
        breakalt   :: d -> d -> d
        endline    :: 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
        default endline    :: Wrappable (UnTrans d) => Trans d => d
        breakpoint = noTrans breakpoint
        breakspace = noTrans breakspace
        breakalt   = noTrans2 breakalt
        endline    = noTrans endline

-- * 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))