{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.Symantic.Document.Sym where

import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable, foldr, foldr1)
import Data.Function ((.), ($))
import Data.Functor (Functor(..))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString)
import Prelude (Integer, fromIntegral, Num(..), pred, undefined, Integral, Real, Enum)
import Text.Show (Show(..))
import qualified Data.Foldable as Foldable
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL

-- * Type 'Nat'
newtype Nat = Nat { unNat :: Integer }
 deriving (Eq, Ord, Show, Integral, Real, Enum)
unLength :: Nat -> Integer
unLength (Nat i) = i
instance Num Nat where
        fromInteger i | 0 <= i    = Nat i
                      | otherwise = undefined
        abs = Nat . abs . unLength
        signum = signum . signum
        Nat x + Nat y = Nat (x + y)
        Nat x * Nat y = Nat (x * y)
        Nat x - Nat y | x >= y    = Nat (x - y)
                      | otherwise = undefined

-- * Class 'Lengthable'
class Lengthable a where
        length :: a -> Nat
instance Lengthable Char where
        length _ = Nat 1
instance Lengthable [a] where
        length = Nat . fromIntegral . List.length
instance Lengthable Text.Text where
        length = Nat . fromIntegral . Text.length
instance Lengthable TL.Text where
        length = Nat . fromIntegral . TL.length

-- * Class 'Splitable'
class Monoid a => Splitable a where
        null  :: a -> Bool
        tail  :: a -> a
        break :: (Char -> Bool) -> a -> (a, a)
        lines :: a -> [a]
        lines = splitOnChar (== '\n')
        words :: a -> [a]
        words = splitOnChar (== ' ')
        splitOnChar :: (Char -> Bool) -> a -> [a]
        splitOnChar c a =
                if null a then []
                else let (l,a') = break c a in
                        l : if null a' then []
                                else let a'' = tail a' in
                                        if null a'' then [mempty] else splitOnChar c a''
instance Splitable String where
        null  = List.null
        tail  = List.tail
        break = List.break
instance Splitable Text.Text where
        null  = Text.null
        tail  = Text.tail
        break = Text.break
instance Splitable TL.Text where
        null  = TL.null
        tail  = TL.tail
        break = TL.break

-- * Type 'Column'
type Column = Nat

-- ** Type 'Indent'
type Indent = Column

-- * Class 'Textable'
class (IsString d, Semigroup d) => Textable d where
        empty     :: d
        charH     :: Char -- ^ XXX: MUST NOT be '\n'
                  -> d
        stringH   :: String -- ^ XXX: MUST NOT contain '\n'
                  -> d
        textH     :: Text.Text -- ^ XXX: MUST NOT contain '\n'
                  -> d
        ltextH    :: TL.Text -- ^ XXX: MUST NOT contain '\n'
                  -> d
        default empty     :: Textable (ReprOf d) => Trans d => d
        default charH     :: Textable (ReprOf d) => Trans d => Char -> d
        default stringH   :: Textable (ReprOf d) => Trans d => String -> d
        default textH     :: Textable (ReprOf d) => Trans d => Text.Text -> d
        default ltextH    :: Textable (ReprOf d) => Trans d => TL.Text -> d
        empty     = trans empty
        charH     = trans . charH
        stringH   = trans . stringH
        textH     = trans . textH
        ltextH    = trans . ltextH

        newline     :: d
        space       :: d
        -- | @x '<+>' y = x '<>' 'space' '<>' y@
        (<+>)       :: d -> d -> d
        -- | @x '</>' y = x '<>' 'newline' '<>' y@
        (</>)       :: d -> d -> d
        int         :: Int -> d
        integer     :: Integer -> d
        char        :: Char    -> d
        string      :: String  -> d
        text        :: Text.Text  -> d
        ltext       :: TL.Text -> d
        catH        :: Foldable f => f d -> d
        catV        :: Foldable f => f d -> d
        unwords     :: Foldable f => f d -> d
        unlines     :: Foldable f => f d -> d
        foldrWith   :: Foldable f => (d -> d -> d) -> f d -> d
        foldWith    :: Foldable f => (d -> d) -> f d -> d
        intercalate :: Foldable f => d -> f d -> d
        between     :: d -> d -> d -> d
        replicate   :: Int -> d -> d

        newline = "\n"
        space   = char ' '
        x <+> y = x <> space <> y
        x </> y = x <> newline <> y
        int     = stringH . show
        integer = stringH . show
        char    = \case '\n' -> newline; c -> charH c
        string  = catV . fmap stringH . lines
        text    = catV . fmap textH   . lines
        ltext   = catV . fmap ltextH  . lines
        catH    = foldr (<>) empty
        catV    = foldrWith (\x y -> x<>newline<>y)
        unwords = foldr (<>) space
        unlines = foldr (\x y -> x<>newline<>y) empty
        foldrWith f ds  = if Foldable.null ds then empty else foldr1 f ds
        foldWith  f     = foldrWith $ \a acc -> a <> f acc
        intercalate sep = foldrWith (\x y -> x<>sep<>y)
        between o c d = o<>d<>c
        replicate cnt t | cnt <= 0  = empty
                        | otherwise = t <> replicate (pred cnt) t

-- * Class 'Indentable'
class Textable d => Indentable d where
        -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
        align :: d -> d
        default align :: Indentable (ReprOf d) => Trans d => d -> d
        align = trans1 align
        -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
        incrIndent :: Indent -> d -> d
        default incrIndent :: Indentable (ReprOf d) => Trans d => Indent -> d -> d
        incrIndent = trans1 . incrIndent
        -- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
        withIndent :: Indent -> d -> d
        default withIndent :: Indentable (ReprOf d) => Trans d => Indent -> d -> d
        withIndent = trans1 . withIndent
        -- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.
        --
        -- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.
        withNewline          :: d -> d -> d
        newlineWithoutIndent :: d
        newlineWithIndent    :: d
        default withNewline          :: Indentable (ReprOf d) => Trans d => d -> d -> d
        default newlineWithoutIndent :: Indentable (ReprOf d) => Trans d => d
        default newlineWithIndent    :: Indentable (ReprOf d) => Trans d => d
        withNewline          = trans2 withNewline
        newlineWithoutIndent = trans newlineWithoutIndent
        newlineWithIndent    = trans newlineWithIndent
        -- | @('column' f)@ write @f@ applied to the current 'Column'.
        column :: (Column -> d) -> d
        default column :: Indentable (ReprOf d) => Trans d => (Column -> d) -> d
        column f = trans $ column (unTrans . f)
        -- | @('indent' f)@ write @f@ applied to the current 'Indent'.
        indent :: (Indent -> d) -> d
        default indent :: Indentable (ReprOf d) => Trans d => (Indent -> d) -> d
        indent f = trans $ indent (unTrans . f)

        -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
        hang :: Indent -> d -> d
        hang ind = align . incrIndent ind

        -- | @('endToEndWidth' d f)@ write @d@ then
        -- @f@ applied to the absolute value of the difference between
        -- the end 'Column' and start 'Column' of @d@.
        --
        -- Note that @f@ is given the end-to-end width,
        -- which is not necessarily the maximal width.
        endToEndWidth :: d -> (Column -> d) -> d
        endToEndWidth d f =
                column $ \c1 ->
                        (d <>) $
                        column $ \c2 ->
                        f $ if c2 - c1 >= 0
                                then c2 - c1
                                else c1 - c2

        -- | @'spaces' ind = 'replicate' ind 'space'@
        spaces :: Indent -> d
        spaces i = replicate (fromIntegral i) space

        -- | @('fill' ind d)@ write @d@,
        -- then if @d@ is not wider than @ind@,
        -- write the difference with 'spaces'.
        fill :: Indent -> d -> d
        fill m d =
                endToEndWidth d $ \w ->
                        case w`compare`m of
                         LT -> spaces $ m - w
                         _  -> empty

        -- | @('breakableFill' ind d)@ write @d@,
        -- then if @d@ is not wider than @ind@, write the difference with 'spaces'
        -- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @ind@.
        breakableFill :: Indent -> d -> d
        breakableFill m d =
                column $ \c ->
                endToEndWidth d $ \w ->
                        case w`compare`m of
                         LT -> spaces (m - w)
                         EQ -> empty
                         GT -> withIndent (c + m) newline

-- * Class 'Breakable'
class (Textable d, Indentable d) => Breakable d where
        -- | @('breakable' f)@ write @f@ applied to whether breaks are activated or not.
        breakable :: (Maybe Column -> d) -> d
        default breakable :: Breakable (ReprOf d) => Trans d => (Maybe Column -> d) -> d
        breakable f = trans $ breakable (unTrans . f)
        -- | @('withBreakable' b d)@ whether to active breaks or not within @d@.
        withBreakable :: Maybe Column -> d -> d
        default withBreakable :: Breakable (ReprOf d) => Trans d => Maybe Column -> d -> d
        withBreakable = trans1 . withBreakable

        -- | @('ifBreak' onWrap onNoWrap)@
        -- write @onWrap@ if @onNoWrap@ leads to a 'Column'
        -- greater or equal to the one sets with 'withBreakable',
        -- otherwise write @onNoWrap@.
        ifBreak :: d -> d -> d
        default ifBreak :: Breakable (ReprOf d) => Trans d => d -> d -> d
        ifBreak = trans2 ifBreak
        -- | @('breakpoint' onNoBreak onBreak d)@
        -- write @onNoBreak@ then @d@ if they fit,
        -- @onBreak@ otherwise.
        breakpoint :: d -> d -> d -> d
        default breakpoint :: Breakable (ReprOf d) => Trans d => d -> d -> d -> d
        breakpoint = trans3 breakpoint

        -- | @('breakableEmpty' d)@ write @d@ if it fits, 'newline' then @d@ otherwise.
        breakableEmpty :: d -> d
        breakableEmpty = breakpoint empty newline

        -- | @x '><' y = x '<>' 'breakableEmpty' y@
        (><) :: d -> d -> d
        x >< y = x <> breakableEmpty y

        -- | @('breakableSpace' d)@ write 'space' then @d@ it they fit,
        -- 'newline' then @d@ otherwise.
        breakableSpace :: d -> d
        breakableSpace = breakpoint space newline

        -- | @x '>+<' y = x '<>' 'breakableSpace' y@
        (>+<) :: d -> d -> d
        x >+< y = x <> breakableSpace y

        -- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
        -- between items of @ds@.
        breakableSpaces :: Foldable f => f d -> d
        breakableSpaces = foldWith breakableSpace

        -- | @('intercalateHorV' sep ds)@
        -- write @ds@ with @sep@ intercalated if the whole fits,
        -- otherwise write 'align' of @ds@ with 'newline' and @sep@ intercalated.
        intercalateHorV :: Foldable f => d -> f d -> d
        intercalateHorV sep xs =
                ifBreak
                 (align $ foldWith ((newline <> sep) <>) xs)
                 (foldWith (sep <>) xs)

-- * Class 'Colorable'
class Colorable d where
        -- | @('colorable' f)@ write @f@ applied to whether colors are activated or not.
        colorable :: (Bool -> d) -> d
        default colorable :: Colorable (ReprOf d) => Trans d => (Bool -> d) -> d
        colorable f = trans $ colorable (unTrans . f)
        -- | @('withColor' b d)@ whether to active colors or not within @d@.
        withColorable :: Bool -> d -> d
        default withColorable :: Colorable (ReprOf d) => Trans d => Bool -> d -> d
        withColorable = trans1 . withColorable

        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     :: Colorable (ReprOf d) => Trans d => d -> d
        default black       :: Colorable (ReprOf d) => Trans d => d -> d
        default red         :: Colorable (ReprOf d) => Trans d => d -> d
        default green       :: Colorable (ReprOf d) => Trans d => d -> d
        default yellow      :: Colorable (ReprOf d) => Trans d => d -> d
        default blue        :: Colorable (ReprOf d) => Trans d => d -> d
        default magenta     :: Colorable (ReprOf d) => Trans d => d -> d
        default cyan        :: Colorable (ReprOf d) => Trans d => d -> d
        default white       :: Colorable (ReprOf d) => Trans d => d -> d
        default blacker     :: Colorable (ReprOf d) => Trans d => d -> d
        default redder      :: Colorable (ReprOf d) => Trans d => d -> d
        default greener     :: Colorable (ReprOf d) => Trans d => d -> d
        default yellower    :: Colorable (ReprOf d) => Trans d => d -> d
        default bluer       :: Colorable (ReprOf d) => Trans d => d -> d
        default magentaer   :: Colorable (ReprOf d) => Trans d => d -> d
        default cyaner      :: Colorable (ReprOf d) => Trans d => d -> d
        default whiter      :: Colorable (ReprOf d) => Trans d => d -> d
        default onBlack     :: Colorable (ReprOf d) => Trans d => d -> d
        default onRed       :: Colorable (ReprOf d) => Trans d => d -> d
        default onGreen     :: Colorable (ReprOf d) => Trans d => d -> d
        default onYellow    :: Colorable (ReprOf d) => Trans d => d -> d
        default onBlue      :: Colorable (ReprOf d) => Trans d => d -> d
        default onMagenta   :: Colorable (ReprOf d) => Trans d => d -> d
        default onCyan      :: Colorable (ReprOf d) => Trans d => d -> d
        default onWhite     :: Colorable (ReprOf d) => Trans d => d -> d
        default onBlacker   :: Colorable (ReprOf d) => Trans d => d -> d
        default onRedder    :: Colorable (ReprOf d) => Trans d => d -> d
        default onGreener   :: Colorable (ReprOf d) => Trans d => d -> d
        default onYellower  :: Colorable (ReprOf d) => Trans d => d -> d
        default onBluer     :: Colorable (ReprOf d) => Trans d => d -> d
        default onMagentaer :: Colorable (ReprOf d) => Trans d => d -> d
        default onCyaner    :: Colorable (ReprOf d) => Trans d => d -> d
        default onWhiter    :: Colorable (ReprOf d) => Trans d => d -> d

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

-- * Class 'Decorable'
class Decorable d where
        -- | @('decorable' f)@ write @f@ applied to whether decorations are activated or not.
        decorable :: (Bool -> d) -> d
        default decorable :: Decorable (ReprOf d) => Trans d => (Bool -> d) -> d
        decorable f = trans $ decorable (unTrans . f)
        -- | @('withColor' b d)@ whether to active decorations or not within @d@.
        withDecorable :: Bool -> d -> d
        default withDecorable :: Decorable (ReprOf d) => Trans d => Bool -> d -> d
        withDecorable = trans1 . withDecorable

        bold      :: d -> d
        underline :: d -> d
        italic    :: d -> d
        default bold      :: Decorable (ReprOf d) => Trans d => d -> d
        default underline :: Decorable (ReprOf d) => Trans d => d -> d
        default italic    :: Decorable (ReprOf d) => Trans d => d -> d
        bold      = trans1 bold
        underline = trans1 underline
        italic    = trans1 italic

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

        -- | Lift a tr to the transformer's.
        trans :: ReprOf tr -> tr
        -- | Unlift a tr from the transformer's.
        unTrans :: tr -> ReprOf tr

        -- | Identity transformation for a unary symantic method.
        trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
        trans1 f = trans . f . unTrans

        -- | Identity transformation for a binary symantic method.
        trans2
         :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
         -> (tr -> tr -> tr)
        trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))

        -- | Identity transformation for a ternary symantic method.
        trans3
         :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
         -> (tr -> tr -> tr -> tr)
        trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))