{-# LANGUAGE OverloadedStrings #-}
-- | Lowers certain CSS properties to plain text.
module Data.CSS.Preprocessor.Text(TextStyle, resolve, StyleTree(..)) where

import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.CSS.Style (PropertyParser(..))
import Data.CSS.StyleTree
import qualified Data.Text as Txt
import Data.Text (Text)

import Data.Maybe (fromMaybe)
import qualified Data.HashMap.Lazy as M
import Data.Function ((&))

import Data.Char (isSpace)

type Counters = [(Text, Integer)]
-- | `PropertyParser` decorator that parses & lowers certain CSS properties to plain text.
data TextStyle p = TextStyle {
    inner :: p,
    content :: [Token],

    counterReset :: Counters,
    counterIncrement :: Counters,
    counterSet :: Counters,

    whiteSpaceCollapse :: Bool,
    newlineCollapse :: Bool
}

instance PropertyParser p => PropertyParser (TextStyle p) where
    temp = TextStyle {
            inner = temp,
            content = [],
            counterReset = [],
            counterIncrement = [],
            counterSet = [],
            whiteSpaceCollapse = True,
            newlineCollapse = True
        }
    inherit parent = TextStyle {
            inner = inherit $ inner parent,
            content = [],
            counterReset = [],
            counterIncrement = [],
            counterSet = [],
            whiteSpaceCollapse = whiteSpaceCollapse parent,
            newlineCollapse = newlineCollapse parent
        }

    shorthand self "content" value = shorthand (inner self) "content" $ removeCounters value
    shorthand _ key value
        | key `elem` ["counter-reset", "counter-increment", "counter-set"],
            Just _ <- parseCounters 0 value = [(key, value)]
    shorthand self "white-space" [Ident val]
        | val `elem` ["normal", "pre", "pre-wrap", "pre-line"] = [("white-space", [Ident val])]
        | otherwise = shorthand (inner self) "white-space" [Ident val]
    shorthand self key value = shorthand (inner self) key value

    longhand _ self "counter-reset" value = (\v -> self {counterReset = v}) <$> parseCounters 0 value
    longhand _ self "counter-increment" value = (\v -> self {counterIncrement = v}) <$> parseCounters 1 value
    longhand _ self "counter-set" value = (\v -> self {counterSet = v}) <$> parseCounters 0 value

    longhand p self "white-space" [Ident "initial"] = setWhiteSpace p self True True "normal"
    longhand p self "white-space" [Ident "normal"] = setWhiteSpace p self True True "normal"
    longhand p self "white-space" [Ident "pre"] = setWhiteSpace p self False False "nowrap"
    longhand p self "white-space" [Ident "nowrap"] = setWhiteSpace p self True True "nowrap"
    longhand p self "white-space" [Ident "pre-wrap"] = setWhiteSpace p self False False "normal"
    longhand p self "white-space" [Ident "pre-line"] = setWhiteSpace p self True False "normal"

    longhand _ self "content" value = Just $ self {content = value}
    longhand parent self key value = (\v -> self {inner = v}) <$> longhand (inner parent ) (inner self) key value

removeCounters :: [Token] -> [Token]
removeCounters (Function "counter":Ident _:RightParen:toks) = String "" : removeCounters toks
removeCounters (Function "counters":Ident _:Comma:String _:toks) = String "" : removeCounters toks
removeCounters (tok:toks) = tok : removeCounters toks
removeCounters [] = []

setWhiteSpace :: PropertyParser p => TextStyle p -> TextStyle p -> Bool -> Bool -> Text -> Maybe (TextStyle p)
setWhiteSpace parent self collapse noNewlines lowered = Just $ self {
        inner = inner self `fromMaybe` longhand (inner parent) (inner self) "white-space" [Ident lowered],
        whiteSpaceCollapse = collapse,
        newlineCollapse = noNewlines
    }
parseCounters :: Integer -> [Token] -> Maybe [(Text, Integer)]
parseCounters _ [Ident "none"] = Just []
parseCounters _ [Ident "initial"] = Just []
parseCounters _ [] = Just []
parseCounters x (Ident counter : Number _ (NVInteger count') : toks) =
    (:) (counter, count') <$> parseCounters x toks
parseCounters x (Ident counter : toks) = (:) (counter, x) <$> parseCounters x toks
parseCounters _ _ = Nothing

-- | Returns inner `PropertyParser` with text properties applied.
resolve :: PropertyParser p => StyleTree (TextStyle p) -> StyleTree p
resolve = resolve' . collapseWS . applyCounters
resolve' :: PropertyParser p => StyleTree (TextStyle p) -> StyleTree p
resolve' = treeMap $ \TextStyle {inner = inner', content = content'} -> (
        fromMaybe inner' $ longhand temp inner' "content" content'
    )

--------
---- Counters
--------
type Context = M.HashMap Text [([Integer], Integer)]

inheritCounters :: Context -> Context -> Context
inheritCounters counterSource valueSource = M.intersectionWith cb valueSource counterSource -- indexed by name & el-path
    where cb val source = [counter | counter@(path, _) <- val, path `elem` [p | (p, _) <- source]]

instantiateCounter :: Context -> Path -> Text -> Integer -> Context
instantiateCounter counters path name val = M.insertWith appendCounter name [(path, val)] counters
    where
        appendCounter new (old@((_:oldPath), _):olds)
            | oldPath == tail path = new ++ olds
            | otherwise =  new ++ (old:olds)
        appendCounter new [] = new
        appendCounter new (_:olds) = new ++ olds
instantiateCounters :: Path -> Counters -> Context -> Context
instantiateCounters path instruct counters = foldl cb counters instruct
    where cb counters' (name, value) = instantiateCounter counters' path name value

incrementCounter :: Context -> Path -> Text -> Integer -> Context
incrementCounter counters path name val = M.insertWith addCounter name [(path, val)] counters
    where
        addCounter ((_, new):_) ((path', old):rest) = (path', new + old):rest
        addCounter [] old = old
        addCounter new [] = new
incrementCounters :: Path -> Counters -> Context -> Context
incrementCounters path instruct counters = foldl cb counters instruct
    where cb counters' (name, value) = incrementCounter counters' path name value

setCounter :: Context -> Path -> Text -> Integer -> Context
setCounter counters path name val = M.insertWith setCounter' name [(path, val)] counters
    where
        setCounter' ((_, val'):_) ((path', _):rest) = (path', val'):rest
        setCounter' [] old = old
        setCounter' new [] = new
setCounters :: Path -> Counters -> Context -> Context
setCounters path instruct counters = foldl cb counters instruct
    where cb counters' (name, value) = setCounter counters' path name value


renderCounters :: Context -> [Token] -> [Token]
renderCounters counters (Function "counter":Ident name:RightParen:toks)
    | Just ((_, count):_) <- name `M.lookup` counters =
        String (Txt.pack $ show count) : renderCounters counters toks
    | otherwise = renderCounters counters toks
renderCounters counters (Function "counters":Ident name:Comma:String sep:RightParen:toks)
    | Just counter <- name `M.lookup` counters = String (Txt.intercalate sep [
        Txt.pack $ show count | (_, count) <- reverse counter
    ]) : renderCounters counters toks
    | otherwise = renderCounters counters toks
renderCounters counters (tok:toks) = tok : renderCounters counters toks
renderCounters _ [] = []

applyCounters :: StyleTree (TextStyle p) -> StyleTree (TextStyle p)
applyCounters = treeOrder applyCounters0 M.empty
applyCounters0 :: Context -> Context -> Path -> TextStyle p -> (Context, TextStyle p)
applyCounters0 counterSource valueSource path node =
    let counters = inheritCounters counterSource valueSource &
            instantiateCounters path (counterReset node) &
            incrementCounters path (counterIncrement node) &
            setCounters path (counterSet node)
    in (counters, node {content = renderCounters counters $ content node})

--------
---- white-space
--------
collapseWS :: StyleTree (TextStyle p) -> StyleTree (TextStyle p)
collapseWS = treeOrder collapseWS0 True
collapseWS0 :: Bool -> Bool -> Path -> TextStyle p -> (Bool, TextStyle p)
collapseWS0 _ _ _ node@(TextStyle {whiteSpaceCollapse = False, newlineCollapse = False}) = (False, node)
collapseWS0 _ inSpace _ node@(TextStyle {
        content = content0,
        whiteSpaceCollapse = wsCollapse,
        newlineCollapse = nlCollapse
    }) = (trailingSpace, node {content = content'})
  where (trailingSpace, content') = collapseWSToks inSpace wsCollapse nlCollapse content0

collapseWSToks :: Bool -> Bool -> Bool -> [Token] -> (Bool, [Token])
collapseWSToks stripStart wsCollapse nlCollapse (String txt:toks) =
    let (trailingSpace, str') = collapseWSStr stripStart wsCollapse nlCollapse $ Txt.unpack txt
        (trailingSpace', toks') = collapseWSToks trailingSpace wsCollapse nlCollapse toks
    in (trailingSpace', String (Txt.pack str'):toks')
collapseWSToks _ wsCollapse nlCollapse (tok:toks) =
    let (trailingSpace, toks') = collapseWSToks False wsCollapse nlCollapse toks
    in (trailingSpace, tok:toks')
collapseWSToks trailingWS _ _ [] = (trailingWS, [])

collapseWSStr, collapseWSStr' :: Bool -> Bool -> Bool -> String -> (Bool, String)
collapseWSStr _ wsCollapse False str@('\n':_) = collapseWSStr' True wsCollapse True str
collapseWSStr True True nlCollapse (ch:str) | isSpace ch = collapseWSStr True True nlCollapse str
collapseWSStr False True nlCollapse str@(ch:_) | isSpace ch = collapseWSStr' True True nlCollapse str
collapseWSStr _ wsCollapse nlCollapse str = collapseWSStr' False wsCollapse nlCollapse str
collapseWSStr' a b c (d:ds) = let (trailing, ds') = collapseWSStr a b c ds in (trailing, d:ds')
collapseWSStr' a _ _ [] = (a, [])