{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
module Data.CSS.Preprocessor.Text.CounterStyle(CounterStyle(..), CounterSystem(..),
defaultCounter, decimalCounter, simpChineseInformal, cjkDecimal, ethiopic,
isValid, parseCounterStyle, CounterStore'(..), parseCounter, defaultCounterStore,
counterRender, counterRenderMarker, ranges', speakAs', CounterStore) where
import Data.CSS.Syntax.Tokens
import Data.CSS.Syntax.StyleSheet
import Data.FileEmbed (embedStringFile, makeRelativeToProject)
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)
data CounterStyle = CounterStyle {
CounterStyle -> CounterSystem
system :: CounterSystem,
CounterStyle -> Text
negativePrefix :: Text,
CounterStyle -> Text
negativeSuffix :: Text,
CounterStyle -> Text
prefix :: Text,
CounterStyle -> Text
suffix :: Text,
CounterStyle -> Maybe [(Int, Int)]
ranges :: Maybe [(Int, Int)],
CounterStyle -> Int
padLength :: Int,
CounterStyle -> Text
padChar :: Text,
CounterStyle -> Maybe CounterStyle
fallback :: Maybe CounterStyle,
CounterStyle -> [Text]
symbols :: [Text],
CounterStyle -> [(Int, Text)]
additiveSymbols :: [(Int, Text)],
CounterStyle -> Maybe Text
speakAs :: Maybe Text
}
data CounterSystem = Cyclic | Fixed Int | Symbolic | Alphabetic | Numeric
| Additive | Chinese { CounterSystem -> Bool
isSimplified :: Bool } | Ethiopic
defaultCounter, decimalCounter :: CounterStyle
ethiopic, simpChineseInformal, cjkDecimal :: CounterStyle
defaultCounter :: CounterStyle
defaultCounter = CounterStyle :: CounterSystem
-> Text
-> Text
-> Text
-> Text
-> Maybe [(Int, Int)]
-> Int
-> Text
-> Maybe CounterStyle
-> [Text]
-> [(Int, Text)]
-> Maybe Text
-> CounterStyle
CounterStyle {
system :: CounterSystem
system = CounterSystem
Symbolic,
negativePrefix :: Text
negativePrefix = "-",
negativeSuffix :: Text
negativeSuffix = "",
prefix :: Text
prefix = "",
suffix :: Text
suffix = ". ",
ranges :: Maybe [(Int, Int)]
ranges = Maybe [(Int, Int)]
forall a. Maybe a
Nothing,
padLength :: Int
padLength = 0,
padChar :: Text
padChar = "",
fallback :: Maybe CounterStyle
fallback = CounterStyle -> Maybe CounterStyle
forall a. a -> Maybe a
Just CounterStyle
decimalCounter,
symbols :: [Text]
symbols = [],
additiveSymbols :: [(Int, Text)]
additiveSymbols = [],
speakAs :: Maybe Text
speakAs = Maybe Text
forall a. Maybe a
Nothing
}
decimalCounter :: CounterStyle
decimalCounter = CounterStyle
defaultCounter {
system :: CounterSystem
system = CounterSystem
Numeric,
symbols :: [Text]
symbols = ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"],
fallback :: Maybe CounterStyle
fallback = Maybe CounterStyle
forall a. Maybe a
Nothing
}
cjkDecimal :: CounterStyle
cjkDecimal = CounterStyle
defaultCounter {
system :: CounterSystem
system = CounterSystem
Numeric,
ranges :: Maybe [(Int, Int)]
ranges = [(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just [(0, Int
forall a. Bounded a => a
maxBound)],
symbols :: [Text]
symbols = ["〇", "一", "二", "三", "四", "五", "六", "七", "八", "九"],
suffix :: Text
suffix = "、"
}
simpChineseInformal :: CounterStyle
simpChineseInformal = CounterStyle
defaultCounter {
system :: CounterSystem
system = Bool -> CounterSystem
Chinese Bool
True,
negativePrefix :: Text
negativePrefix = "负",
symbols :: [Text]
symbols = ["零", "一", "二", "三", "四", "五", "六", "七", "八", "九"],
additiveSymbols :: [(Int, Text)]
additiveSymbols = [(0, ""), (10, "十"), (100, "百"), (1000, "千")],
suffix :: Text
suffix = "、",
fallback :: Maybe CounterStyle
fallback = CounterStyle -> Maybe CounterStyle
forall a. a -> Maybe a
Just CounterStyle
cjkDecimal
}
ethiopic :: CounterStyle
ethiopic = CounterStyle
defaultCounter {
system :: CounterSystem
system = CounterSystem
Ethiopic,
symbols :: [Text]
symbols = ["", "፩", "፪", "፫", "፬", "፭", "፮", "፯", "፰", "፱"],
additiveSymbols :: [(Int, Text)]
additiveSymbols = [(0, ""), (10, "፲"), (20, "፳"), (30, "፴"), (40, "፵"),
(50, "፶"), (60, "፷"), (70, "፸"), (80, "፹"), (90, "፺")],
suffix :: Text
suffix = "/ "
}
isValid :: CounterStyle -> Bool
isValid :: CounterStyle -> Bool
isValid CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Additive, additiveSymbols :: CounterStyle -> [(Int, Text)]
additiveSymbols = [] } = Bool
False
isValid self :: CounterStyle
self@CounterStyle {
system :: CounterStyle -> CounterSystem
system = Chinese _, symbols :: CounterStyle -> [Text]
symbols = [Text]
syms, additiveSymbols :: CounterStyle -> [(Int, Text)]
additiveSymbols = [(Int, Text)]
markers
} = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
syms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 10 Bool -> Bool -> Bool
&& [(Int, Text)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Text)]
markers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 4 Bool -> Bool -> Bool
&& CounterStyle -> Maybe [(Int, Int)]
ranges CounterStyle
self Maybe [(Int, Int)] -> Maybe [(Int, Int)] -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe [(Int, Int)]
forall a. Maybe a
Nothing
isValid CounterStyle {
system :: CounterStyle -> CounterSystem
system = CounterSystem
Ethiopic, symbols :: CounterStyle -> [Text]
symbols = [Text]
units, additiveSymbols :: CounterStyle -> [(Int, Text)]
additiveSymbols = [(Int, Text)]
tens
} = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
units Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 10 Bool -> Bool -> Bool
&& [(Int, Text)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Text)]
tens Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 10
isValid CounterStyle { symbols :: CounterStyle -> [Text]
symbols = [] } = Bool
False
isValid _ = Bool
True
type CounterStore = HashMap Text CounterStyle
parseCounterProperty :: CounterStore -> (Text, [Token]) ->
CounterStyle -> CounterStyle
parseCounterProperty :: CounterStore -> (Text, [Token]) -> CounterStyle -> CounterStyle
parseCounterProperty _ ("system", [Ident "cyclic"]) self :: CounterStyle
self = CounterStyle
self {system :: CounterSystem
system = CounterSystem
Cyclic}
parseCounterProperty _ ("system", [Ident "fixed"]) self :: CounterStyle
self = CounterStyle
self {system :: CounterSystem
system = Int -> CounterSystem
Fixed 1}
parseCounterProperty _ ("system", [Ident "fixed", Number _ (NVInteger x :: Integer
x)]) self :: CounterStyle
self
= CounterStyle
self { system :: CounterSystem
system = Int -> CounterSystem
Fixed (Int -> CounterSystem) -> Int -> CounterSystem
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
x }
parseCounterProperty _ ("system", [Ident "symbolic"]) self :: CounterStyle
self =
CounterStyle
self {system :: CounterSystem
system = CounterSystem
Symbolic }
parseCounterProperty _ ("system", [Ident "alphabetic"]) self :: CounterStyle
self =
CounterStyle
self { system :: CounterSystem
system = CounterSystem
Alphabetic }
parseCounterProperty _ ("system", [Ident "numeric"]) self :: CounterStyle
self =
CounterStyle
self { system :: CounterSystem
system = CounterSystem
Numeric }
parseCounterProperty _ ("system", [Ident "-argo-chinese", Ident x :: Text
x]) self :: CounterStyle
self =
CounterStyle
self { system :: CounterSystem
system = Bool -> CounterSystem
Chinese (Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "simplified") }
parseCounterProperty _ ("system", [Ident "-argo-ethiopic"]) self :: CounterStyle
self =
CounterStyle
self { system :: CounterSystem
system = CounterSystem
Ethiopic }
parseCounterProperty _ ("system", [Ident "extends", Ident _]) self :: CounterStyle
self = CounterStyle
self
parseCounterProperty _ ("negative", [x :: Token
x]) self :: CounterStyle
self | Just pre :: Text
pre <- Token -> Maybe Text
parseSymbol Token
x =
CounterStyle
self { negativePrefix :: Text
negativePrefix = Text
pre, negativeSuffix :: Text
negativeSuffix = "" }
parseCounterProperty _ ("negative", [x :: Token
x, y :: Token
y]) self :: CounterStyle
self
| Just pre :: Text
pre <- Token -> Maybe Text
parseSymbol Token
x, Just suf :: Text
suf <- Token -> Maybe Text
parseSymbol Token
y =
CounterStyle
self { negativePrefix :: Text
negativePrefix = Text
pre, negativeSuffix :: Text
negativeSuffix = Text
suf }
parseCounterProperty _ ("prefix", [x :: Token
x]) self :: CounterStyle
self | Just pre :: Text
pre <- Token -> Maybe Text
parseSymbol Token
x =
CounterStyle
self { prefix :: Text
prefix = Text
pre }
parseCounterProperty _ ("suffix", [x :: Token
x]) self :: CounterStyle
self | Just suf :: Text
suf <- Token -> Maybe Text
parseSymbol Token
x =
CounterStyle
self { suffix :: Text
suffix = Text
suf }
parseCounterProperty _ ("range", [Ident "auto"]) self :: CounterStyle
self = CounterStyle
self {ranges :: Maybe [(Int, Int)]
ranges = Maybe [(Int, Int)]
forall a. Maybe a
Nothing}
parseCounterProperty _ ("range", toks :: [Token]
toks) self :: CounterStyle
self | Just rs :: [(Int, Int)]
rs <- [Token] -> Maybe [(Int, Int)]
parseRanges (Token
CommaToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
toks) =
CounterStyle
self { ranges :: Maybe [(Int, Int)]
ranges = [(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just [(Int, Int)]
rs }
parseCounterProperty _ ("pad", [Number _ (NVInteger x :: Integer
x), y :: Token
y]) self :: CounterStyle
self
| Just char :: Text
char <- Token -> Maybe Text
parseSymbol Token
y = CounterStyle
self {
padLength :: Int
padLength = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
x, padChar :: Text
padChar = Text
char
}
parseCounterProperty styles :: CounterStore
styles ("fallback", [Ident name :: Text
name]) self :: CounterStyle
self = CounterStyle
self {
fallback :: Maybe CounterStyle
fallback = CounterStyle -> Maybe CounterStyle
forall a. a -> Maybe a
Just (CounterStyle -> Maybe CounterStyle)
-> CounterStyle -> Maybe CounterStyle
forall a b. (a -> b) -> a -> b
$ CounterStyle -> Text -> CounterStore -> CounterStyle
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HM.lookupDefault CounterStyle
decimalCounter Text
name CounterStore
styles
}
parseCounterProperty _ ("symbols", toks :: [Token]
toks) self :: CounterStyle
self | (Token -> Bool) -> [Token] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Text -> Bool) -> (Token -> Maybe Text) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Maybe Text
parseSymbol) [Token]
toks
= CounterStyle
self { symbols :: [Text]
symbols = (Token -> Text) -> [Token] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> (Token -> Maybe Text) -> Token -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Maybe Text
parseSymbol) [Token]
toks }
parseCounterProperty _ ("additive-symbols", toks :: [Token]
toks) self :: CounterStyle
self
| Just syms :: [(Int, Text)]
syms <- [Token] -> Maybe [(Int, Text)]
parseAdditiveSymbols (Token
CommaToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
toks) =
CounterStyle
self { additiveSymbols :: [(Int, Text)]
additiveSymbols = [(Int, Text)]
syms }
parseCounterProperty _ ("speak-as", [Ident "auto"]) self :: CounterStyle
self =
CounterStyle
self { speakAs :: Maybe Text
speakAs = Maybe Text
forall a. Maybe a
Nothing }
parseCounterProperty styles :: CounterStore
styles ("speak-as", [Ident x :: Text
x]) self :: CounterStyle
self
| Text
x Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["bullets", "numbers", "words", "spell-out"] =
CounterStyle
self { speakAs :: Maybe Text
speakAs = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x }
| Just super :: CounterStyle
super <- Text -> CounterStore -> Maybe CounterStyle
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
x CounterStore
styles = CounterStyle
self { speakAs :: Maybe Text
speakAs = CounterStyle -> Maybe Text
speakAs CounterStyle
super }
| Bool
otherwise = CounterStyle
self
parseCounterProperty _ _ self :: CounterStyle
self = CounterStyle
self
parseRanges :: [Token] -> Maybe [(Int, Int)]
parseRanges :: [Token] -> Maybe [(Int, Int)]
parseRanges (Comma:a :: Token
a:b :: Token
b:toks :: [Token]
toks) | Just self :: [(Int, Int)]
self <- [Token] -> Maybe [(Int, Int)]
parseRanges [Token]
toks = case (Token
a, Token
b) of
(Ident "infinite", Ident "infinite") -> [(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just ((Int
forall a. Bounded a => a
minBound, Int
forall a. Bounded a => a
maxBound)(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:[(Int, Int)]
self)
(Ident "infinite", Number _ (NVInteger x :: Integer
x)) ->
[(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just ((Int
forall a. Bounded a => a
minBound, Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
x)(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:[(Int, Int)]
self)
(Number _ (NVInteger x :: Integer
x), Ident "infinite") ->
[(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just ((Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
x, Int
forall a. Bounded a => a
maxBound)(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:[(Int, Int)]
self)
(Number _ (NVInteger x :: Integer
x), Number _ (NVInteger y :: Integer
y)) ->
[(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just ((Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
x, Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
y)(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:[(Int, Int)]
self)
_ -> Maybe [(Int, Int)]
forall a. Maybe a
Nothing
parseRanges [] = [(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just []
parseRanges _ = Maybe [(Int, Int)]
forall a. Maybe a
Nothing
parseAdditiveSymbols :: [Token] -> Maybe [(Int, Text)]
parseAdditiveSymbols :: [Token] -> Maybe [(Int, Text)]
parseAdditiveSymbols (Comma:Number _ (NVInteger x :: Integer
x):y :: Token
y:toks :: [Token]
toks)
| Just self :: [(Int, Text)]
self <- [Token] -> Maybe [(Int, Text)]
parseAdditiveSymbols [Token]
toks, Just sym :: Text
sym <- Token -> Maybe Text
parseSymbol Token
y =
[(Int, Text)] -> Maybe [(Int, Text)]
forall a. a -> Maybe a
Just ((Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
x, Text
sym)(Int, Text) -> [(Int, Text)] -> [(Int, Text)]
forall a. a -> [a] -> [a]
:[(Int, Text)]
self)
parseAdditiveSymbols [] = [(Int, Text)] -> Maybe [(Int, Text)]
forall a. a -> Maybe a
Just []
parseAdditiveSymbols _ = Maybe [(Int, Text)]
forall a. Maybe a
Nothing
parseCounterStyle :: CounterStore -> [Token] -> (CounterStore, [Token])
parseCounterStyle :: CounterStore -> [Token] -> (CounterStore, [Token])
parseCounterStyle store :: CounterStore
store (Whitespace:toks :: [Token]
toks) = CounterStore -> [Token] -> (CounterStore, [Token])
parseCounterStyle CounterStore
store [Token]
toks
parseCounterStyle store :: CounterStore
store (Ident name :: Text
name:toks :: [Token]
toks)
| ((props :: [(Text, [Token])]
props, ""), toks' :: [Token]
toks') <- Parser ([(Text, [Token])], Text)
parseProperties [Token]
toks =
let super :: CounterStyle
super = case Text -> [(Text, [Token])] -> Maybe [Token]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup "system" [(Text, [Token])]
props of
Just [Ident "extends", Ident name' :: Text
name'] ->
CounterStyle -> Text -> CounterStore -> CounterStyle
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HM.lookupDefault CounterStyle
decimalCounter Text
name' CounterStore
store
_ -> CounterStyle
defaultCounter
style :: CounterStyle
style = ((Text, [Token]) -> CounterStyle -> CounterStyle)
-> CounterStyle -> [(Text, [Token])] -> CounterStyle
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CounterStore -> (Text, [Token]) -> CounterStyle -> CounterStyle
parseCounterProperty CounterStore
store) CounterStyle
super [(Text, [Token])]
props
in (Text -> CounterStyle -> CounterStore -> CounterStore
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
name CounterStyle
style CounterStore
store, [Token]
toks')
parseCounterStyle store :: CounterStore
store toks :: [Token]
toks = (CounterStore
store, [Token] -> [Token]
skipAtRule [Token]
toks)
parseSymbol :: Token -> Maybe Text
parseSymbol :: Token -> Maybe Text
parseSymbol (Ident x :: Text
x) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
parseSymbol (String x :: Text
x) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
parseSymbol _ = Maybe Text
forall a. Maybe a
Nothing
data CounterStore' = CounterStore { CounterStore' -> CounterStore
unwrap :: CounterStore }
instance StyleSheet CounterStore' where
addRule :: CounterStore' -> StyleRule -> CounterStore'
addRule self :: CounterStore'
self _ = CounterStore'
self
addAtRule :: CounterStore' -> Text -> [Token] -> (CounterStore', [Token])
addAtRule (CounterStore self :: CounterStore
self) "counter-style" toks :: [Token]
toks =
let (self' :: CounterStore
self', toks' :: [Token]
toks') = CounterStore -> [Token] -> (CounterStore, [Token])
parseCounterStyle CounterStore
self [Token]
toks
in (CounterStore -> CounterStore'
CounterStore CounterStore
self', [Token]
toks')
addAtRule self :: CounterStore'
self _ toks :: [Token]
toks = (CounterStore'
self, [Token] -> [Token]
skipAtRule [Token]
toks)
defaultCounterStore :: CounterStore'
defaultCounterStore :: CounterStore'
defaultCounterStore =
CounterStore' -> Text -> CounterStore'
forall s. StyleSheet s => s -> Text -> s
parse (CounterStore -> CounterStore'
CounterStore CounterStore
forall k v. HashMap k v
HM.empty) (Text -> CounterStore') -> Text -> CounterStore'
forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack
$(makeRelativeToProject "src/Data/CSS/Preprocessor/Text/counter-styles.css" >>=
embedStringFile)
fallbackSym :: Text
fallbackSym :: Text
fallbackSym = "\0"
counterRenderCore :: CounterStyle -> Int -> Text
counterRenderCore :: CounterStyle -> Int -> Text
counterRenderCore CounterStyle { system :: CounterStyle -> CounterSystem
system = Fixed n :: Int
n, symbols :: CounterStyle -> [Text]
symbols = [Text]
syms } x :: Int
x
| Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
syms Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = [Text]
syms [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)
| Bool
otherwise = Text
fallbackSym
counterRenderCore _ x :: Int
x | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = Text
fallbackSym
counterRenderCore CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Cyclic, symbols :: CounterStyle -> [Text]
symbols = [Text]
syms } x :: Int
x =
[Text]
syms [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! (Int -> Int
forall a. Enum a => a -> a
pred Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
syms)
counterRenderCore CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Symbolic, symbols :: CounterStyle -> [Text]
symbols = [Text]
syms } x :: Int
x =
Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int -> Int
forall a. Integral a => a -> a -> a
quot Int
x' Int
n) Int -> Text -> Text
`Txt.replicate` ([Text]
syms [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Integral a => a -> a -> a
rem Int
x' Int
n)
where (n :: Int
n, x' :: Int
x') = ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
syms, Int -> Int
forall a. Enum a => a -> a
pred Int
x)
counterRenderCore CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Alphabetic, symbols :: CounterStyle -> [Text]
symbols = [Text]
syms } x :: Int
x = Int -> Text
inner Int
x
where
n :: Int
n = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
syms
inner :: Int -> Text
inner 0 = ""
inner y :: Int
y = let x' :: Int
x' = Int -> Int
forall a. Enum a => a -> a
pred Int
y in Int -> Text
inner (Int -> Int -> Int
forall a. Integral a => a -> a -> a
quot Int
x' Int
n) Text -> Text -> Text
`Txt.append` ([Text]
syms [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Integral a => a -> a -> a
rem Int
x' Int
n)
counterRenderCore CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Numeric, symbols :: CounterStyle -> [Text]
symbols = [Text]
syms } 0 = [Text]
syms [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! 0
counterRenderCore CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Numeric, symbols :: CounterStyle -> [Text]
symbols = [Text]
syms } x :: Int
x = Int -> Text
inner Int
x
where
n :: Int
n = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
syms
inner :: Int -> Text
inner 0 = ""
inner y :: Int
y = Int -> Text
inner (Int -> Int -> Int
forall a. Integral a => a -> a -> a
quot Int
y Int
n) Text -> Text -> Text
`Txt.append` ([Text]
syms [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Integral a => a -> a -> a
rem Int
y Int
n)
counterRenderCore CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Additive, additiveSymbols :: CounterStyle -> [(Int, Text)]
additiveSymbols = [(Int, Text)]
syms } 0
| Just sym :: Text
sym <- Int -> [(Int, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup 0 [(Int, Text)]
syms = Text
sym
| Bool
otherwise = Text
fallbackSym
counterRenderCore CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Additive, additiveSymbols :: CounterStyle -> [(Int, Text)]
additiveSymbols = [(Int, Text)]
syms } w :: Int
w
| '\0' Char -> Text -> Bool
`elem'` [(Int, Text)] -> Int -> Text
inner [(Int, Text)]
syms Int
w = Text
fallbackSym
| Bool
otherwise = [(Int, Text)] -> Int -> Text
inner [(Int, Text)]
syms Int
w
where
elem' :: Char -> Text -> Bool
elem' ch :: Char
ch txt :: Text
txt = Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
ch (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
txt
inner :: [(Int, Text)] -> Int -> Text
inner _ 0 = ""
inner ((0, _):syms' :: [(Int, Text)]
syms') x :: Int
x = [(Int, Text)] -> Int -> Text
inner [(Int, Text)]
syms' Int
x
inner ((weight :: Int
weight, _):syms' :: [(Int, Text)]
syms') x :: Int
x | Int
weight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
x = [(Int, Text)] -> Int -> Text
inner [(Int, Text)]
syms' Int
x
inner ((weight :: Int
weight, sym :: Text
sym):syms' :: [(Int, Text)]
syms') x :: Int
x =
Int -> Text -> Text
Txt.replicate Int
reps Text
sym Text -> Text -> Text
`Txt.append` [(Int, Text)] -> Int -> Text
inner [(Int, Text)]
syms' Int
x'
where
reps :: Int
reps = Int -> Int -> Int
forall a. Integral a => a -> a -> a
quot Int
x Int
weight
x' :: Int
x' = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
weight Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
reps
inner [] _ = "\0"
counterRenderCore CounterStyle { system :: CounterStyle -> CounterSystem
system = Chinese _, symbols :: CounterStyle -> [Text]
symbols = (sym :: Text
sym:_) } 0 = Text
sym
counterRenderCore CounterStyle {
system :: CounterStyle -> CounterSystem
system = Chinese simplified :: Bool
simplified, symbols :: CounterStyle -> [Text]
symbols = [Text]
syms, additiveSymbols :: CounterStyle -> [(Int, Text)]
additiveSymbols = [(Int, Text)]
markers
} x :: Int
x = [Text] -> Text
Txt.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Text) -> [(Int, Int)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Text
renderDigit ([(Int, Int)] -> [Text]) -> [(Int, Int)] -> [Text]
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> [(Int, Int)]
forall b a. (Eq b, Num b) => [(a, b)] -> [(a, b)]
collapse0s ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$
[(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a]
reverse ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [(Int, Int)]
forall a. [a] -> [(Int, a)]
enumerate ([Int] -> [(Int, Int)]) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
decimalDigits Int
x
where
collapse0s :: [(a, b)] -> [(a, b)]
collapse0s ((i :: a
i, 0):digits :: [(a, b)]
digits) = [(a, b)] -> [(a, b)]
inner [(a, b)]
digits
where
inner :: [(a, b)] -> [(a, b)]
inner ((_, 0):digits' :: [(a, b)]
digits') = [(a, b)] -> [(a, b)]
inner [(a, b)]
digits'
inner [] = []
inner digits' :: [(a, b)]
digits' = (a
i, 0)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)] -> [(a, b)]
collapse0s [(a, b)]
digits'
collapse0s (digit :: (a, b)
digit:digits :: [(a, b)]
digits) = (a, b)
digit(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)] -> [(a, b)]
collapse0s [(a, b)]
digits
collapse0s [] = []
renderDigit :: (Int, Int) -> Text
renderDigit (_, 0) = [Text]
syms [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! 0
renderDigit (1,1) | Bool
simplified, [_, _] <- Int -> [Int]
decimalDigits Int
x = [Text]
markers' [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! 1
renderDigit (place :: Int
place, digit :: Int
digit) = [Text] -> Text
Txt.concat [[Text]
syms [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
digit, [Text]
markers' [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
place]
markers' :: [Text]
markers' = ((Int, Text) -> Text) -> [(Int, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Text) -> Text
forall a b. (a, b) -> b
snd [(Int, Text)]
markers
counterRenderCore CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Ethiopic, symbols :: CounterStyle -> [Text]
symbols = (_:sym :: Text
sym:_) } 1 = Text
sym
counterRenderCore CounterStyle {
system :: CounterStyle -> CounterSystem
system = CounterSystem
Ethiopic, symbols :: CounterStyle -> [Text]
symbols = [Text]
unitSyms, additiveSymbols :: CounterStyle -> [(Int, Text)]
additiveSymbols = [(Int, Text)]
tenSyms
} x :: Int
x = [Text] -> Text
Txt.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> [(Int, (Int, Int))] -> [Text]
renderPairs Bool
True ([(Int, (Int, Int))] -> [Text]) -> [(Int, (Int, Int))] -> [Text]
forall a b. (a -> b) -> a -> b
$
[(Int, (Int, Int))] -> [(Int, (Int, Int))]
forall a. [a] -> [a]
reverse ([(Int, (Int, Int))] -> [(Int, (Int, Int))])
-> [(Int, (Int, Int))] -> [(Int, (Int, Int))]
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> [(Int, (Int, Int))]
forall a. [a] -> [(Int, a)]
enumerate ([(Int, Int)] -> [(Int, (Int, Int))])
-> [(Int, Int)] -> [(Int, (Int, Int))]
forall a b. (a -> b) -> a -> b
$ [Int] -> [(Int, Int)]
forall b. Num b => [b] -> [(b, b)]
pairDigits ([Int] -> [(Int, Int)]) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
decimalDigits Int
x
where
pairDigits :: [b] -> [(b, b)]
pairDigits (units :: b
units:tens :: b
tens:digits :: [b]
digits) = (b
tens,b
units)(b, b) -> [(b, b)] -> [(b, b)]
forall a. a -> [a] -> [a]
:[b] -> [(b, b)]
pairDigits [b]
digits
pairDigits [units :: b
units] = (0, b
units)(b, b) -> [(b, b)] -> [(b, b)]
forall a. a -> [a] -> [a]
:[]
pairDigits [] = []
renderPairs :: Bool -> [(Int, (Int, Int))] -> [Text]
renderPairs isBigEnd :: Bool
isBigEnd (group :: (Int, (Int, Int))
group:groups :: [(Int, (Int, Int))]
groups) =
Bool -> (Int, (Int, Int)) -> Text
renderPair Bool
isBigEnd (Int, (Int, Int))
groupText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:Bool -> [(Int, (Int, Int))] -> [Text]
renderPairs Bool
False [(Int, (Int, Int))]
groups
renderPairs _ [] = []
renderPair' :: Bool -> (Int, (Int, Int)) -> Text
renderPair' :: Bool -> (Int, (Int, Int)) -> Text
renderPair' _ (_,(0, 0)) = ""
renderPair' True (_, (0,1)) = ""
renderPair' _ (i :: Int
i, (0,1)) | Int -> Bool
forall a. Integral a => a -> Bool
odd Int
i = ""
renderPair' _ (_, (tens :: Int
tens, units :: Int
units)) =
(((Int, Text) -> Text) -> [(Int, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Text) -> Text
forall a b. (a, b) -> b
snd [(Int, Text)]
tenSyms [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
tens) Text -> Text -> Text
`Txt.append` ([Text]
unitSyms [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
units)
renderPair :: Bool -> (Int, (Int, Int)) -> Text
renderPair _ (i :: Int
i, (0,0)) | Int -> Bool
forall a. Integral a => a -> Bool
odd Int
i = ""
renderPair isBigEnd :: Bool
isBigEnd (0, group :: (Int, Int)
group) = Bool -> (Int, (Int, Int)) -> Text
renderPair' Bool
isBigEnd (0, (Int, Int)
group)
renderPair isBigEnd :: Bool
isBigEnd (i :: Int
i, group :: (Int, Int)
group)
| Int -> Bool
forall a. Integral a => a -> Bool
odd Int
i = Bool -> (Int, (Int, Int)) -> Text
renderPair' Bool
isBigEnd (Int
i, (Int, Int)
group) Text -> Text -> Text
`Txt.append` "፻"
| Int -> Bool
forall a. Integral a => a -> Bool
even Int
i = Bool -> (Int, (Int, Int)) -> Text
renderPair' Bool
isBigEnd (Int
i, (Int, Int)
group) Text -> Text -> Text
`Txt.append` "፼"
renderPair _ _ = ""
decimalDigits :: Int -> [Int]
decimalDigits :: Int -> [Int]
decimalDigits 0 = []
decimalDigits x :: Int
x = Int -> Int -> Int
forall a. Integral a => a -> a -> a
rem Int
x 10Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:Int -> [Int]
decimalDigits (Int -> Int -> Int
forall a. Integral a => a -> a -> a
quot Int
x 10)
enumerate :: [a] -> [(Int, a)]
enumerate :: [a] -> [(Int, a)]
enumerate = [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int] -> [a] -> [(Int, a)]) -> [Int] -> [a] -> [(Int, a)]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
forall a. Enum a => a -> [a]
enumFrom 0
counterRenderMarker :: CounterStyle -> Int -> Text
counterRenderMarker :: CounterStyle -> Int -> Text
counterRenderMarker self :: CounterStyle
self x :: Int
x =
[Text] -> Text
Txt.concat [CounterStyle -> Text
prefix CounterStyle
self, CounterStyle -> Int -> Text
counterRender CounterStyle
self Int
x, CounterStyle -> Text
suffix CounterStyle
self]
counterRender :: CounterStyle -> Int -> Text
counterRender :: CounterStyle -> Int -> Text
counterRender self :: CounterStyle
self@CounterStyle { fallback :: CounterStyle -> Maybe CounterStyle
fallback = Just self' :: CounterStyle
self' } x :: Int
x
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [(Int, Int)] -> Bool
forall t. Ord t => t -> [(t, t)] -> Bool
inRange Int
x ([(Int, Int)] -> Bool) -> [(Int, Int)] -> Bool
forall a b. (a -> b) -> a -> b
$ CounterStyle -> [(Int, Int)]
ranges' CounterStyle
self = CounterStyle -> Int -> Text
counterRender CounterStyle
self' Int
x
| CounterStyle -> Int -> Text
counterRenderCore CounterStyle
self Int
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
fallbackSym = CounterStyle -> Int -> Text
counterRender CounterStyle
self' Int
x
where
inRange :: t -> [(t, t)] -> Bool
inRange y :: t
y ((start :: t
start, end :: t
end):rest :: [(t, t)]
rest)
| t
y t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
start Bool -> Bool -> Bool
&& t
y t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
end = Bool
True
| Bool
otherwise = t -> [(t, t)] -> Bool
inRange t
y [(t, t)]
rest
inRange _ [] = Bool
False
counterRender self :: CounterStyle
self@CounterStyle { padLength :: CounterStyle -> Int
padLength = Int
m, padChar :: CounterStyle -> Text
padChar = Text
pad } x :: Int
x
| Fixed _ <- CounterStyle -> CounterSystem
system CounterStyle
self = Text
text
| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = [Text] -> Text
Txt.concat [
CounterStyle -> Text
negativePrefix CounterStyle
self,
CounterStyle -> Int -> Text
counterRender CounterStyle
self { ranges :: Maybe [(Int, Int)]
ranges = [(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just [(0, Int
forall a. Bounded a => a
maxBound)] } (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ -Int
x,
CounterStyle -> Text
negativeSuffix CounterStyle
self
]
| Text
text Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
fallbackSym = String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
x
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
m = Int -> Text -> Text
Txt.replicate (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Text
pad Text -> Text -> Text
`Txt.append` Text
text
| Bool
otherwise = Text
text
where
text :: Text
text = CounterStyle -> Int -> Text
counterRenderCore CounterStyle
self Int
x
n :: Int
n = Text -> Int
Txt.length Text
text
infiniteRange :: [(Int, Int)]
infiniteRange :: [(Int, Int)]
infiniteRange = [(Int
forall a. Bounded a => a
minBound, Int
forall a. Bounded a => a
maxBound)]
ranges' :: CounterStyle -> [(Int, Int)]
ranges' :: CounterStyle -> [(Int, Int)]
ranges' CounterStyle { ranges :: CounterStyle -> Maybe [(Int, Int)]
ranges = Just ret :: [(Int, Int)]
ret } = [(Int, Int)]
ret
ranges' CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Cyclic } = [(Int, Int)]
infiniteRange
ranges' CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Numeric } = [(Int, Int)]
infiniteRange
ranges' CounterStyle { system :: CounterStyle -> CounterSystem
system = Fixed _ } = [(Int, Int)]
infiniteRange
ranges' CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Alphabetic } = [(1, Int
forall a. Bounded a => a
maxBound)]
ranges' CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Symbolic } = [(1, Int
forall a. Bounded a => a
maxBound)]
ranges' CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Additive } = [(0, Int
forall a. Bounded a => a
maxBound)]
ranges' CounterStyle { system :: CounterStyle -> CounterSystem
system = Chinese _ } = [(-9999, 9999)]
ranges' CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Ethiopic } = [(1, Int
forall a. Bounded a => a
maxBound)]
speakAs' :: CounterStyle -> Text
speakAs' :: CounterStyle -> Text
speakAs' CounterStyle { speakAs :: CounterStyle -> Maybe Text
speakAs = Just ret :: Text
ret } = Text
ret
speakAs' CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Alphabetic } = "spell-out"
speakAs' CounterStyle { system :: CounterStyle -> CounterSystem
system = CounterSystem
Cyclic } = "bullets"
speakAs' _ = "numbers"
parseCounter :: CounterStore -> [Token] -> Maybe (CounterStyle, [Token])
parseCounter :: CounterStore -> [Token] -> Maybe (CounterStyle, [Token])
parseCounter _ (Function "symbols":Ident name :: Text
name:toks :: [Token]
toks)
| Just system' :: CounterSystem
system' <- Text -> [(Text, CounterSystem)] -> Maybe CounterSystem
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup Text
name [
("cyclic", CounterSystem
Cyclic), ("numeric", CounterSystem
Numeric), ("alphabetic", CounterSystem
Alphabetic),
("symbolic", CounterSystem
Symbolic), ("fixed", Int -> CounterSystem
Fixed 1)
], Just (syms :: [Text]
syms, toks' :: [Token]
toks') <- [Token] -> Maybe ([Text], [Token])
parseArgs [Token]
toks =
(CounterStyle, [Token]) -> Maybe (CounterStyle, [Token])
forall a. a -> Maybe a
Just (CounterStyle
defaultCounter { system :: CounterSystem
system = CounterSystem
system', symbols :: [Text]
symbols = [Text]
syms }, [Token]
toks')
where
parseArgs :: [Token] -> Maybe ([Text], [Token])
parseArgs (String sym :: Text
sym:toks' :: [Token]
toks') | Just (syms :: [Text]
syms,tail' :: [Token]
tail') <- [Token] -> Maybe ([Text], [Token])
parseArgs [Token]
toks' =
([Text], [Token]) -> Maybe ([Text], [Token])
forall a. a -> Maybe a
Just (Text
symText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
syms, [Token]
tail')
parseArgs (RightParen:toks' :: [Token]
toks') = ([Text], [Token]) -> Maybe ([Text], [Token])
forall a. a -> Maybe a
Just ([],[Token]
toks')
parseArgs _ = Maybe ([Text], [Token])
forall a. Maybe a
Nothing
parseCounter store :: CounterStore
store (Ident name :: Text
name:toks :: [Token]
toks)
| Just ret :: CounterStyle
ret <- Text -> CounterStore -> Maybe CounterStyle
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
name CounterStore
store, CounterStyle -> Bool
isValid CounterStyle
ret = (CounterStyle, [Token]) -> Maybe (CounterStyle, [Token])
forall a. a -> Maybe a
Just (CounterStyle
ret, [Token]
toks)
| Bool
otherwise = (CounterStyle, [Token]) -> Maybe (CounterStyle, [Token])
forall a. a -> Maybe a
Just (CounterStyle
decimalCounter, [Token]
toks)
parseCounter _ (String sym :: Text
sym:toks :: [Token]
toks) =
(CounterStyle, [Token]) -> Maybe (CounterStyle, [Token])
forall a. a -> Maybe a
Just (CounterStyle
defaultCounter {system :: CounterSystem
system = CounterSystem
Cyclic, symbols :: [Text]
symbols = [Text
sym], suffix :: Text
suffix = " "}, [Token]
toks)
parseCounter _ _ = Maybe (CounterStyle, [Token])
forall a. Maybe a
Nothing