{-# LANGUAGE OverloadedStrings #-}
module Data.CSS.Preprocessor.Text.CounterStyle(CounterStyle(..), CounterSystem(..),
    defaultCounter, decimalCounter, isValid, parseCounter, CounterStore'(..),
    counterRender, ranges', speakAs', parseCounter) where
import Data.CSS.Syntax.Tokens
import Data.CSS.Syntax.StyleSheet

import Data.Text as Txt (Text, unpack)
import Data.HashMap.Lazy as HM
import Data.Maybe (isJust, fromJust)
import Data.List (foldl')

-- NOTE: No support for image "symbols" yet.
data CounterStyle = CounterStyle {
    system :: CounterSystem,
    negativePrefix :: Text,
    negativeSuffix :: Text,
    prefix :: Text,
    suffix :: Text,
    ranges :: Maybe [(Int, Int)],
    padLength :: Int,
    padChar :: Text,
    fallback :: Maybe CounterStyle,
    symbols :: [Text],
    additiveSymbols :: [(Int, Text)],
    speakAs :: Maybe Text
}
data CounterSystem =
    Cyclic | Fixed Int | Symbolic | Alphabetic | Numeric | Additive

defaultCounter = CounterStyle {
    system = Symbolic,
    negativePrefix = "-",
    negativeSuffix = "",
    prefix = "",
    suffix = ". ",
    ranges = Nothing,
    padLength = 0,
    padChar = "",
    fallback = Just decimalCounter,
    symbols = [], -- Must be overriden!
    additiveSymbols = [], -- Alternative requirement!
    speakAs = Nothing
}
decimalCounter = defaultCounter {
    system = Numeric,
    symbols = ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"],
    fallback = Nothing
}

isValid :: CounterStyle -> Bool
isValid CounterStyle { system = Additive, additiveSymbols = [] } = False
isValid CounterStyle { symbols = [] } = False
isValid _ = True

type CounterStore = HashMap Text CounterStyle
parseCounterProperty :: CounterStore -> (Text, [Token]) ->
        CounterStyle -> CounterStyle
parseCounterProperty _ ("system", [Ident "cyclic"]) self = self {system = Cyclic}
parseCounterProperty _ ("system", [Ident "fixed"]) self = self {system = Fixed 1}
parseCounterProperty _ ("system", [Ident "fixed", Number _ (NVInteger x)]) self
    = self { system = Fixed $ fromInteger x }
parseCounterProperty _ ("system", [Ident "symbolic"]) self =
    self {system = Symbolic }
parseCounterProperty _ ("system", [Ident "alphabetic"]) self =
    self { system = Alphabetic }
parseCounterProperty _ ("system", [Ident "numeric"]) self =
    self { system = Numeric }
-- Handled by caller so property overrides work correctly.
parseCounterProperty _ ("system", [Ident "extends", Ident _]) self = self

parseCounterProperty _ ("negative", [x]) self | Just prefix <- parseSymbol x =
    self { negativePrefix = prefix, negativeSuffix = "" }
parseCounterProperty _ ("negative", [x, y]) self
    | Just prefix <- parseSymbol x, Just suffix <- parseSymbol y =
        self { negativePrefix = prefix, negativeSuffix = suffix }

parseCounterProperty _ ("prefix", [x]) self | Just pre <- parseSymbol x =
    self { prefix = pre }
parseCounterProperty _ ("suffix", [x]) self | Just suf <- parseSymbol x =
    self { suffix = suf }

parseCounterProperty _ ("range", [Ident "auto"]) self = self {ranges = Nothing}
parseCounterProperty _ (("range", toks):props) self
    | Just rs <- parseRanges (Comma:toks) = self { ranges = Just rs }

parseCounterProperty _ ("pad", [Number _ (NVInteger x), y]) self
    | Just char <- parseSymbol y = self {
            padLength = fromInteger x, padChar = char
          }
parseCounterProperty styles ("fallback", [Ident name]) self = self {
        fallback = Just $ HM.lookupDefault decimalCounter name styles
      }
parseCounterProperty _ ("symbols", toks) self | all (isJust . parseSymbol) toks
    = self { symbols = map (fromJust . parseSymbol) toks }
parseCounterProperty _ ("additive-symbols", toks) self
    | Just syms <- parseAdditiveSymbols (Comma:toks) =
        self { additiveSymbols = syms }

parseCounterProperty _ ("speak-as", Ident "auto") self =
    self { speakAs = Nothing }
parseCounterProperty styles ("speak-as", Ident x) self
    | x `elem` ["bullets", "numbers", "words", "spell-out"] =
        self { speakAs = Just x }
    | Just super <- HM.lookup x styles = self { speakAs = speakAs super }
    | otherwise = self
parseCounterProperty _ _ self = self

parseRanges (Comma:x:y:toks) | Just self <- parseRanges toks = case (x, y) of
    (Ident "infinite", Ident "infinite") -> Just ((minBound, maxBound):self)
    (Ident "infinite", Number _ (NVInteger x)) ->
        Just ((minBound, fromInteger x):self)
    (Number _ (NVInteger x), Ident "infinite") ->
        Just ((fromInteger x, maxBound):self)
    (Number _ (NVInteger x), Number _ (NVInteger y)) ->
        Just ((fromInteger x, fromInteger y):self)
    _ -> Nothing
parseRanges [] = Just []
parseRanges _ = Nothing

parseAdditiveSymbols (Comma:Number _ (NumericInteger x):y:toks)
    | Just self <- parseRanges toks, Just sym <- parseSymbol y =
        Just ((fromInteger x, y):self)
parseAdditiveSymbols [] = Just []
parseAdditiveSymbols _ = Nothing

parseCounter :: CounterStore -> [Token] -> (CounterStore, [Token])
parseCounter store (Whitespace:toks) = parseCounter store toks
parseCounter store (Ident name:toks)
    | Just ((props, ""), tail) <- parseProperties toks =
        let super = case Prelude.lookup "system" props of
                [Ident "extends", Ident name'] ->
                    HM.lookupDefault decimalCounter name' store
                _ -> defaultCounter
            style = foldr (parseCounterProperty store) super props
        in if isValid style then HM.insert name style store else store
parseCounter store toks = (store, skipAtRule toks)

parseSymbol :: Token -> Maybe Text
parseSymbol (Ident x) = Just x
parseSymbol (String x) = Just x

data CounterStore' = CounterStore { unwrap :: CounterStore }
instance StyleSheet CounterStore' where
    addRule self _ = self
    addAtRule (CounterStore self) "counter-style" toks =
        let (self', tail) = parseCounter self toks
        in (CounterStore self', tail)
    addAtRule self _ toks = (self, skipAtRule toks)

---

fallbackSym :: Text
fallbackSym = "\0"

counterRenderCore :: CounterStyle -> Int -> Text
counterRenderCore CounterStyle { system = Cyclic, symbols = syms } x =
    syms !! rem x (length syms)
counterRenderCore CounterStyle { system = Fixed n, symbols = syms } x
    | x - n < length syms = syms !! (x - n)
    | otherwise = fallbackSym
counterRenderCore CounterStyle { system = Symbolic, symbols = syms } x =
    quot x n `Txt.replicate` (syms !! rem x n)
  where n = length syms
counterRenderCore CounterStyle { system = Alphabetic, symbols = syms } x = inner x
  where
    n = length syms
    inner 0 = ""
    inner x = let x' = pred x in (syms !! rem x' n) `Txt.append` inner (quot x' n)
counterRenderCore CounterStyle { system = Numeric, symbols = syms } 0 = syms !! 0
counterRenderCore CounterStyle { system = Numeric, symbols = syms } x = inner x
  where
    n = length syms
    inner 0 = ""
    inner x = (syms !! rem x n) `Txt.append` inner (quot x n)
counterRenderCore CounterStyle { system = Additive, additiveSymbols = syms } 0
    | Just sym <- Prelude.lookup 0 syms = s `Txt.append` sym
    | otherwise = fallbackSym
counterRenderCore CounterStyle { system = Additive, additiveSymbols = syms } w =
    | '\0' `Txt.elem` inner syms w = fallbackSym
    | otherwise = inner syms w
  where
    inner _ 0 = ""
    inner ((0, _):syms) x = inner syms x
    inner ((weight, _):syms) x | weight > x = inner syms x
    inner ((weight, sym):syms) x =
        Txt.replicate reps sym `Txt.append` inner syms x'
      where
        reps = quot x weight
        x' = x - weight * reps
    inner [] x = "\0" -- Run fallback counter!

counterRender :: CounterStyle -> Int -> Text
counterRender self x
    | x < 0 = Txt.concat [prefix self, negativePrefix self, inner self -x,
                          negativeSuffix self, suffix self]
    | otherwise = Txt.concat [prefix self, inner self x, suffix self]
  where
    inner self@CounterStyle { fallback = Just self' } x
        | not $ inRange x $ ranges' self = inner self' x
        | counterRenderCore self x == fallbackSym = inner self' x
    inner self x
        | text == fallbackSym = show x -- NOTE: Shouldn't happen
        | n < padLength self =
            (padLength self - n `Txt.replicate` padChar self) `Txt.append` text
        | otherwise = text
      where
        text = counterRenderCore self x
        n = Txt.length text
    inRange ((start, end):ranges) x
        | x >= start && x <= end = True
        | otherwise = inRange ranges x
    inRange [] _ = False

infiniteRange = [(minBound, maxBound)]
ranges' :: CounterStyle -> [(Int, Int)]
ranges' CounterStyle { ranges = Just ret } = ret
ranges' CounterStyle { system = Cyclic } = infiniteRange
ranges' CounterStyle { system = Numeric } = infiniteRange
ranges' CounterStyle { system = Fixed _ } = infiniteRange
ranges' CounterStyle { system = Alphabetic } = [(1, maxBound)]
ranges' CounterStyle { system = Symbolic } = [(1, maxBound)]
ranges' CounterStyle { system = Additive } = [(0, maxBound)]

speakAs' :: CounterStyle -> Text
speakAs' CounterStyle { speakAs = Just ret } = ret
speakAs' CounterStyle { system = Alphabetic } = "spell-out"
speakAs' CounterStyle { system = Cyclic } = "bullets"
speakAs' _ = "numbers"

---

parseCounter :: CounterStore -> [Token] -> (CounterStyle, [Token])
parseCounter _ (Func "symbols":Ident system:toks)
    | Just system' <- Prelude.lookup system [
        ("cyclic", Cyclic), ("numeric", Numeric), ("alphabetic", Alphabetic),
        ("symbolic", Symbolic), ("fixed", Fixed 1)
      ], Just (syms, toks') <- parseArgs toks =
        Just (defaultCounter{ system = system', symbols = syms }, tail)
  where
    parseArgs (String sym:toks) | Just (syms,tail) <- parseArgs toks =
        Just (sym:syms, tail)
    parseArgs (RightParen:toks) = Just ([],toks)
    parseArgs _ = Nothing
parseCounter store (Ident name:toks)
    | Just ret <- HM.lookup name store = Just (ret, toks)
parseCounter _ (String sym:toks) =
    Just (defaultCounter { system = Symbolic, syms = [sym], suffix = " " }, toks)
parseCounter _ _ = Nothing