{-# LANGUAGE OverloadedStrings #-} module Data.CSS.Preprocessor.Text.CounterStyle(CounterStyle(..), CounterSystem(..), defaultCounter, decimalCounter, simpChineseInformal, cjkDecimal, ethiopic, isValid, parseCounterStyle, CounterStore'(..), parseCounter, counterRender, counterRenderMarker, ranges', speakAs') 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 | Chinese { isSimplified :: Bool } | Ethiopic defaultCounter, decimalCounter :: CounterStyle ethiopic, simpChineseInformal, cjkDecimal :: 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 } -- These are here mostly for testing... cjkDecimal = defaultCounter { system = Numeric, ranges = Just [(0, maxBound)], symbols = ["〇", "一", "二", "三", "四", "五", "六", "七", "八", "九"], suffix = "、" } simpChineseInformal = defaultCounter { system = Chinese True, negativePrefix = "负", symbols = ["零", "一", "二", "三", "四", "五", "六", "七", "八", "九"], additiveSymbols = [(0, ""), (10, "十"), (100, "百"), (1000, "千")], suffix = "、", fallback = Just cjkDecimal } ethiopic = defaultCounter { system = Ethiopic, symbols = ["", "፩", "፪", "፫", "፬", "፭", "፮", "፯", "፰", "፱"], additiveSymbols = [(0, ""), (10, "፲"), (20, "፳"), (30, "፴"), (40, "፵"), (50, "፶"), (60, "፷"), (70, "፸"), (80, "፹"), (90, "፺")], suffix = "/ " } isValid :: CounterStyle -> Bool isValid CounterStyle { system = Additive, additiveSymbols = [] } = False isValid self@CounterStyle { system = Chinese _, symbols = syms, additiveSymbols = markers } = length syms == 10 && length markers >= 4 && ranges self == Nothing isValid CounterStyle { system = Ethiopic, symbols = units, additiveSymbols = tens } = length units == 10 && length tens == 10 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 } parseCounterProperty _ ("system", [Ident "-argo-chinese", Ident x]) self = self { system = Chinese (x == "simplified") } parseCounterProperty _ ("system", [Ident "-argo-ethiopic"]) self = self { system = Ethiopic } -- 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! -- Following https://w3c.github.io/csswg-drafts/css-counter-styles-3/#limited-chinese -- 1. If the counter value is 0, the representation is the character for 0 -- specified for the given counter style. Skip the rest of this algorithm. counterRenderCore CounterStyle { system = Chinese _, symbols = (sym:_) } 0 = sym counterRenderCore CounterStyle { system = Chinese simplified, symbols = syms, additiveSymbols = markers } x = Txt.concat $ map renderDigit $ collapse0s $ reverse $ enumerate $ decimalDigits x where -- Implements step 4. collapse0s ((i, 0):digits) = inner digits where inner ((_, 0):digits') = inner digits' -- Drop trailing 0s inner [] = [] -- Collapse any remaining (consecutive?) zeroes into a single 0 digit. inner digits' = (i, 0):collapse0s digits' collapse0s (digit:digits) = digit:collapse0s digits collapse0s [] = [] renderDigit (_, 0) = syms !! 0 -- Don't append digit marker for zero, step 2. -- 3. For the informal styles, if the counter value is between 10 and 19, -- remove the 10s digit (leave the digit marker). renderDigit (1,1) | simplified, [_, _] <- decimalDigits x = markers' !! 1 -- Select characters per steps 2 & 5 renderDigit (place, digit) = Txt.concat [syms !! digit, markers' !! place] markers' = map snd markers -- Following https://w3c.github.io/csswg-drafts/css-counter-styles-3/#ethiopic-numeric-counter-style -- 1. If the number is 1, return "፩" (U+1369). counterRenderCore CounterStyle { system = Ethiopic, symbols = (sym:_) } 1 = sym counterRenderCore CounterStyle { system = Ethiopic, symbols = unitSyms, additiveSymbols = tenSyms } x = Txt.concat $ renderPairs True $ reverse $ enumerate $ pairDigits $ decimalDigits x where -- 2. Split the number into groups of two digits, -- starting with the least significant decimal digit. pairDigits (units:tens:digits) = (tens,units):pairDigits digits pairDigits [units] = (0, units):[] pairDigits [] = [] renderPairs isBigEnd (group:groups) = renderPair isBigEnd group:renderPairs False groups renderPairs _ [] = [] -- Handle step 4's exceptions. renderPair' :: Bool -> (Int, (Int, Int)) -> Text renderPair' _ (_,(0, 0)) = "" renderPair' True (_, (0,1)) = "" renderPair' _ (i, (0,1)) | odd i = "" -- Step 5 renderPair' _ (_, (tens, units)) = (map snd tenSyms !! tens) `Txt.append` (unitSyms !! units) -- Step 6 & 7 renderPair _ (i, (0,0)) | odd i = "" renderPair isBigEnd (0, group) = renderPair' isBigEnd (0, group) renderPair isBigEnd (i, group) | odd i = renderPair' isBigEnd (i, group) `Txt.append` "፻" | even i = renderPair' isBigEnd (i, group) `Txt.append` "፼" renderPair _ _ = "" -- Silence warnings, above case should not fallthrough. decimalDigits :: Int -> [Int] decimalDigits 0 = [] decimalDigits x = rem x 10:decimalDigits (quot x 10) enumerate :: [a] -> [(Int, a)] enumerate = zip $ enumFrom 0 counterRenderMarker :: CounterStyle -> Int -> Text counterRenderMarker = counterRender True counterRender :: Bool -> CounterStyle -> Int -> Text counterRender isMarker self x | isMarker = Txt.concat [prefix self, inner self x, suffix 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' | x' < 0 = Txt.concat [ negativePrefix self', inner self' { fallback = Nothing } $ -x', negativeSuffix self' ] | 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)] ranges' CounterStyle { system = Chinese _ } = [(-9999, 9999)] ranges' CounterStyle { system = Ethiopic } = [(1, 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