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

import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.CSS.Style (PropertyParser(..))
import Data.CSS.ShorthandUtil (parseUnorderedShorthand)
import Data.CSS.StyleTree
import qualified Data.Text as Txt
import Data.Text (Text)
import Data.CSS.Preprocessor.Text.CounterStyle (parseCounter, CounterStore'(..))

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,
    counterProps :: [(Text, [Token])],

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

    whiteSpaceCollapse :: Bool,
    newlineCollapse :: Bool,

    isListItem :: Bool,
    listStyleImage :: [Token],
    listStyleType :: [Token],
    listPosInside :: Bool,
    markerMatchParent :: Bool
}

instance PropertyParser p => PropertyParser (TextStyle p) where
    temp = TextStyle {
            inner = temp,
            counterProps = [],
            counterReset = [],
            counterIncrement = [],
            counterSet = [],
            whiteSpaceCollapse = True,
            newlineCollapse = True,
            isListItem = False,
            listStyleImage = [],
            listStyleType = [Ident "disc"],
            listPosInside = False,
            markerMatchParent = False
        }
    inherit parent = TextStyle {
            inner = inherit $ inner parent,
            counterProps = [],
            counterReset = [],
            counterIncrement = [],
            counterSet = [],
            whiteSpaceCollapse = whiteSpaceCollapse parent,
            newlineCollapse = newlineCollapse parent,
            isListItem = False,
            listStyleImage = listStyleImage parent,
            listStyleType = listStyleType parent,
            listPosInside = listPosInside parent,
            markerMatchParent = markerMatchParent parent
        }

    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 "list-style" toks = parseUnorderedShorthand self subprops toks
      where subprops = ["list-style-image", "list-style-type", "list-style-position"]
    shorthand TextStyle { inner = s } k v
        | Just _ <- longhand s s k $ removeCounters v = [(k, v)]
        | otherwise = shorthand s k v

    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 p self@TextStyle {inner=self'} "display" [Ident "list"] = Just self {
        isListItem = True,
        inner=fromMaybe self' $ longhand (inner p) self' "display" [Ident "block"]
    }
    longhand TextStyle {inner=p'} self@TextStyle {inner = self'} "display" value
        | Just ret <- longhand p' self' "display" value = Just self {
            isListItem = False,
            inner = ret
          }
        | otherwise = Nothing

    longhand _ self "list-style-image" [Ident kw] | kw `elem` ["initial", "none"]
        = Just self { listStyleImage = [] }
    longhand TextStyle { inner = p' } self@TextStyle { inner = self' }
            "list-style-image" value
        | Just _ <- longhand p' self' "background-image" value = Just self {
            listStyleImage = value -- This is a valid image according to caller.
          }
        | otherwise = Nothing
    longhand _ self "list-style-type" [Ident "initial"] =
        Just self { listStyleType = [Ident "disc"] }
    longhand _ self "list-style-type" toks | Just _ <- parseCounter M.empty toks =
        Just self { listStyleType = toks }
    longhand _ self "list-style-position" [Ident "inside"] =
        Just self { listPosInside = True }
    longhand _ self "list-style-position" [Ident "outside"] =
        Just self { listPosInside = False }
    longhand _ self "list-style-position" [Ident "initial"] =
        Just self { listPosInside = False }
    longhand _ self "marker-side" [Ident "match-self"] =
        Just self { markerMatchParent = False }
    longhand _ self "marker-side" [Ident "match-parent"] =
        Just self { markerMatchParent = True }
    longhand _ self "marker-side" [Ident "initial"] =
        Just self { markerMatchParent = False }

    -- Capture `content` properties & anything else using counter(s) functions.
    -- This is important in Rhapsode for the sake of navigational markers.
    -- Ignoring invalid properties.
    longhand TextStyle { inner = p' } TextStyle { inner = self' } key value
        | Nothing <- longhand p' self' key $ removeCounters value = Nothing
    longhand parent self key value
        | key == "content" || Function "counter" `elem` value || Function "counters" `elem` value =
            Just $ self { counterProps = insertList key value $ counterProps self }
        | otherwise = (\v -> self {inner = v}) <$> longhand (inner parent ) (inner self) key value

insertList :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
insertList key value list | Nothing <- lookup key list = (key, value) : list
    | otherwise = [(k, if k == key then value else v) | (k, v) <- list]

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', counterProps = props} -> foldl resolveProp inner' props
resolveProp :: PropertyParser p => p -> (Text, [Token]) -> p
resolveProp sty (key, value) = sty `fromMaybe` longhand temp sty key value

--------
---- 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 {
        counterProps = [(k, renderCounters counters v) | (k, v) <- counterProps node]
    })

--------
---- white-space
--------
content :: TextStyle p -> [Token]
content = fromMaybe [] . lookup "content" . counterProps
setContent :: [Token] -> TextStyle p -> TextStyle p
setContent value self = self {
        counterProps = [(k, if k == "content" then value else v) | (k, v) <- counterProps self]
    }

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 {
        whiteSpaceCollapse = wsCollapse,
        newlineCollapse = nlCollapse
    }) = (trailingSpace, setContent content' node)
  where (trailingSpace, content') = collapseWSToks inSpace wsCollapse nlCollapse $ content node

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, [])