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

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

-- 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, decimalCounter :: CounterStyle
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 pre <- parseSymbol x =
    self { negativePrefix = pre, negativeSuffix = "" }
parseCounterProperty _ ("negative", [x, y]) self
    | Just pre <- parseSymbol x, Just suf <- parseSymbol y =
        self { negativePrefix = pre, negativeSuffix = suf }

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) 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 :: [Token] -> Maybe [(Int, Int)]
parseRanges (Comma:a:b:toks) | Just self <- parseRanges toks = case (a, b) 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 :: [Token] -> Maybe [(Int, Text)]
parseAdditiveSymbols (Comma:Number _ (NVInteger x):y:toks)
    | Just self <- parseAdditiveSymbols toks, Just sym <- parseSymbol y =
        Just ((fromInteger x, sym):self)
parseAdditiveSymbols [] = Just []
parseAdditiveSymbols _ = Nothing

parseCounterStyle :: CounterStore -> [Token] -> (CounterStore, [Token])
parseCounterStyle store (Whitespace:toks) = parseCounterStyle store toks
parseCounterStyle store (Ident name:toks)
    | ((props, ""), toks') <- parseProperties toks =
        let super = case Prelude.lookup "system" props of
                Just [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,
            toks'
        )
parseCounterStyle store toks = (store, skipAtRule toks)

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

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

---

fallbackSym :: Text
fallbackSym = "\0"

counterRenderCore :: CounterStyle -> Int -> Text
counterRenderCore CounterStyle { system = Cyclic, symbols = syms } x =
    syms !! (pred x `rem` 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 =
    succ (quot x' n) `Txt.replicate` (syms !! rem x' n)
  where (n, x') = (length syms, pred x)
counterRenderCore CounterStyle { system = Alphabetic, symbols = syms } x = inner x
  where
    n = length syms
    inner 0 = ""
    inner y = let x' = pred y in inner (quot x' n) `Txt.append` (syms !! rem 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 y = inner (quot y n) `Txt.append` (syms !! rem y n)
counterRenderCore CounterStyle { system = Additive, additiveSymbols = syms } 0
    | Just sym <- Prelude.lookup 0 syms = sym
    | otherwise = fallbackSym
counterRenderCore CounterStyle { system = Additive, additiveSymbols = syms } w
    | '\0' `elem'` inner syms w = fallbackSym
    | otherwise = inner syms w
  where
    elem' ch txt = elem ch $ unpack txt
    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 [] _ = "\0" -- Run fallback counter!

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

infiniteRange :: [(Int, Int)]
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] -> Maybe (CounterStyle, [Token])
parseCounter _ (Function "symbols":Ident name:toks)
    | Just system' <- Prelude.lookup name [
        ("cyclic", Cyclic), ("numeric", Numeric), ("alphabetic", Alphabetic),
        ("symbolic", Symbolic), ("fixed", Fixed 1)
      ], Just (syms, toks') <- parseArgs toks =
        Just (defaultCounter { system = system', symbols = syms }, toks')
  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 = Cyclic, symbols = [sym], suffix = " "}, toks)
parseCounter _ _ = Nothing