typst-0.7: src/Typst/Methods.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Typst.Methods
( getMethod,
formatNumber,
applyPureFunction
)
where
import Control.Monad (MonadPlus (mplus), foldM, void)
import Control.Monad.Reader (MonadReader (ask), MonadTrans (lift))
import qualified Data.Array as Array
import qualified Data.Foldable as F
import Data.List (intersperse, sort, sortOn)
import qualified Data.Map as M
import qualified Data.Map.Ordered as OM
import Data.Maybe (fromMaybe, listToMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import Text.Parsec
import Text.Parsec.String (Parser)
import Typst.Module.Standard (applyPureFunction)
import Typst.Regex
( RE (..),
RegexMatch (..),
extract,
makeRE,
match,
matchAll,
replaceRegex,
splitRegex,
)
import Typst.Types
import Typst.Util (allArgs, makeFunction, namedArg, nthArg)
import Data.Time (toGregorian, dayOfWeek, formatTime, defaultTimeLocale, UTCTime(..))
-- import Debug.Trace
getMethod ::
MonadFail m =>
(forall n. Monad n => Val -> MP n ()) ->
Val ->
Text ->
m Val
getMethod updateVal val fld = do
let methodUnimplemented name =
fail $
"Method "
<> show name
<> " is not yet implemented"
let noMethod typename name =
fail $
typename
<> " does not have a method "
<> show name
case val of
VDict m ->
case fld of
"len" ->
pure $ makeFunction $ pure $ VInteger (fromIntegral $ OM.size m)
"at" ->
pure $ makeFunction $ do
key <- nthArg 1
defval <- namedArg "default" VNone
case OM.lookup (Identifier key) m of
Nothing -> pure defval
Just v -> pure v
"insert" -> do
pure $ makeFunction $ do
key <- nthArg 1
v <- nthArg 2
lift $ updateVal $ VDict $ m OM.|> (Identifier key, v)
pure VNone
"keys" ->
pure $
makeFunction $
pure $
VArray $
V.fromList $
map (\(Identifier t, _) -> VString t) $
OM.assocs m
"values" ->
pure $ makeFunction $ pure $ VArray $ V.fromList $ map snd $ OM.assocs m
"pairs" ->
pure $ makeFunction $ do
pure $
VArray $
V.fromList $
map
( \(Identifier k, v) ->
VArray (V.fromList [VString k, v])
)
(OM.assocs m)
"remove" ->
pure $ makeFunction $ do
key <- nthArg 1
case OM.lookup (Identifier key) m of
Nothing -> pure VNone
Just oldval -> do
lift $ updateVal $ VDict $ OM.delete (Identifier key) m
pure oldval
_ -> case OM.lookup (Identifier fld) m of
Just x -> pure x
Nothing -> fail $ show (Identifier fld) <> " not found"
VColor col ->
case fld of
"darken" -> pure $ makeFunction $ do
(n :: Rational) <- nthArg 1
pure $ VColor $ case col of
RGB r g b o -> RGB (r * (1 - n)) (g * (1 - n)) (b * (1 - n)) o
CMYK c m y k -> CMYK (c * (1 - n)) (m * (1 - n)) (y * (1 - n)) (k * (1 - n))
Luma x -> Luma (x * (1 - n))
"lighten" -> pure $ makeFunction $ do
(n :: Rational) <- nthArg 1
pure $ VColor $ case col of
RGB r g b o ->
RGB
(r + ((1 - r) * n))
(g + ((1 - g) * n))
(b + ((1 - b) * n))
o
CMYK c m y k ->
CMYK
(c + ((1 - c) * n))
(m + ((1 - m) * n))
(y + ((1 - y) * n))
(k + ((1 - k) * n))
Luma x -> Luma (x + ((1 - x) * n))
"negate" -> pure $ makeFunction $ do
pure $ VColor $ case col of
RGB r g b o -> RGB (1 - r) (1 - g) (1 - b) o
CMYK c m y k -> CMYK (1 - c) (1 - m) (1 - y) k
Luma x -> Luma (1 - x)
_ -> noMethod "Color" fld
VString t -> do
let toPos n =
if n < 0
then T.length t + n
else n
case fld of
"len" ->
pure $ makeFunction $ pure $ VInteger (fromIntegral $ T.length t)
"rev" ->
pure $ makeFunction $ pure $ VString (T.reverse t)
"first" ->
if T.null t
then fail "string is empty"
else pure $ makeFunction $ pure $ VString $ T.take 1 t
"last" ->
if T.null t
then fail "string is empty"
else pure $ makeFunction $ pure $ VString $ T.takeEnd 1 t
"at" ->
pure $ makeFunction $ do
n <- toPos <$> nthArg 1
pure $ VString $ T.take 1 $ T.drop n t
"slice" ->
pure $ makeFunction $ do
start <- toPos <$> nthArg 1
mbcount <- namedArg "count" Nothing
end <- (toPos <$> nthArg 2) `mplus`
pure (maybe (T.length t) (+ start) mbcount)
if end < start
then pure $ VString ""
else pure $ VString $ T.take (end - start) $ T.drop start t
"clusters" -> pure $ makeFunction $ do
-- TODO this isn't right, but we'd need fancier libraries
-- to get at grapheme clusters
pure $ VArray $ V.fromList $ map VString $ T.chunksOf 1 t
"codepoints" -> pure $ makeFunction $ do
pure $ VArray $ V.fromList $ map VString $ T.chunksOf 1 t
"contains" -> pure $ makeFunction $ do
(patt :: RE) <- nthArg 1
pure $ VBoolean $ match patt t
"starts-with" -> pure $ makeFunction $ do
(RE reStr _) <- nthArg 1
patt <- makeRE ("^" <> reStr)
pure $ VBoolean $ match patt t
"ends-with" -> pure $ makeFunction $ do
(RE reStr _) <- nthArg 1
patt <- makeRE (reStr <> "$")
pure $ VBoolean $ match patt t
"find" -> pure $ makeFunction $ do
(patt :: RE) <- nthArg 1
pure $
let ((_, m, _) :: (Text, Text, Text)) = match patt t
in VString m
"position" -> pure $ makeFunction $ do
(patt :: RE) <- nthArg 1
pure $
let ((off, _) :: (Int, Int)) = match patt t
in VInteger (fromIntegral off)
"match" -> pure $ makeFunction $ do
(patt :: RE) <- nthArg 1
let (pre, whole, (_post :: Text), subs) = match patt t
if T.null whole
then pure VNone
else
pure $
VDict $
OM.fromList
[ ("start", VInteger (fromIntegral $ T.length pre)),
("end", VInteger (fromIntegral $ T.length pre + T.length whole)),
("text", VString whole),
("captures", VArray $ V.fromList $ map VString subs)
]
"matches" -> pure $ makeFunction $ do
(patt :: RE) <- nthArg 1
let matchToDict matchArray =
case Array.elems matchArray of
[] -> VNone
(off, len) : subs ->
let submatches = map (\(o, l) -> VString $ extract (o, l) t) subs
in VDict $
OM.fromList
[ ("start", VInteger (fromIntegral off)),
("end", VInteger (fromIntegral off + fromIntegral len)),
("text", VString $ extract (off, len) t),
("captures", VArray $ V.fromList submatches)
]
let matches = map matchToDict $ matchAll patt t
pure $ VArray $ V.fromList matches
"replace" -> pure $ makeFunction $ do
patt :: RE <- nthArg 1
(replacement :: Val) <- nthArg 2
mbCount :: Maybe Int <- namedArg "count" Nothing
case mbCount of
Just 0 -> pure $ VString t
_ ->
case replacement of
VString r ->
pure $ VString $ replaceRegex patt mbCount (const r) t
VSymbol (Symbol r _ _) ->
pure $ VString $ replaceRegex patt mbCount (const r) t
VFunction _ _ f ->
pure $
VString $
replaceRegex
patt
mbCount
( \(RegexMatch start end txt captures) ->
case applyPureFunction
f
[ VDict $
OM.fromList
[ ("start", VInteger (fromIntegral start)),
("end", VInteger (fromIntegral end)),
("text", VString txt),
("captures", VArray (V.fromList (map VString captures)))
]
] of
Success (VString s) -> s
_ -> ""
)
t
_ -> fail "replacement must be string or function"
"trim" -> pure $ makeFunction $ do
(RE patt _) <- nthArg 1 `mplus` makeRE "[[:space:]]*"
(repeated :: Bool) <- namedArg "repeat" True
(mbAt :: Maybe Val) <- namedArg "at" Nothing
let patt' =
if repeated
then "(" <> patt <> ")*"
else patt
patt'' <- case mbAt of
Just (VAlignment (Just HorizStart) _) -> makeRE $ "^" <> patt'
Just (VAlignment (Just HorizEnd) _) -> makeRE $ patt' <> "$"
Nothing -> makeRE $ "(^" <> patt' <> ")|(" <> patt' <> "$)"
_ -> fail "'at' expected either 'start' or 'end'"
pure $ VString $ replaceRegex patt'' Nothing (const mempty) t
"split" -> pure $ makeFunction $ do
arg <- nthArg 1
case arg of
VString "" ->
pure $ VArray $ V.fromList $ map VString $ "" : T.chunksOf 1 t ++ [""]
VString patt -> pure $ VArray $ V.fromList $ map VString $ T.splitOn patt t
VRegex patt ->
pure $
VArray $
V.fromList $
map VString $
splitRegex patt t
_ ->
-- defaults to split on whitespace
pure $ VArray $ V.fromList $ map VString $ T.words t
_ -> noMethod "String" fld
VCounter key ->
case fld of
"display" -> pure $ makeFunction $ do
mbnum <- M.lookup key . evalCounters <$> lift getState
maybe (fail "counter not defined") (pure . VInteger) mbnum
"step" -> pure $ makeFunction $ do
lift $ updateState $ \st ->
st {evalCounters = M.adjust (+ 1) key $ evalCounters st}
pure VNone
"update" -> pure $ makeFunction $ do
mbnum <- M.lookup key . evalCounters <$> lift getState
case mbnum of
Nothing -> fail "counter not defined"
Just num -> do
newval <- nthArg 1
(newnum :: Integer) <-
case newval of
VFunction _ _ fn ->
case applyPureFunction fn [VInteger num] of
Failure e -> fail e
Success v -> fromVal v
_ -> fromVal newval
lift $ updateState $ \st ->
st {evalCounters = M.adjust (const newnum) key $ evalCounters st}
pure VNone
"at" -> methodUnimplemented fld
"final" -> methodUnimplemented fld
_ -> noMethod "Counter" fld
VContent cs ->
case fld of
"func" -> pure $ makeFunction $ do
case F.toList cs of
[Elt name _ _] -> lift $ lookupIdentifier name
[Txt _] -> lift $ lookupIdentifier "text"
_ -> pure $ makeFunction $ do
xs <- allArgs
pure $ VContent $ foldMap valToContent xs
"has" -> pure $ makeFunction $ do
f <- nthArg 1
let hasField (Elt _ _ fields) = isJust $ M.lookup (Identifier f) fields
hasField _ = False
pure $ VBoolean $ any hasField cs
"at" -> pure $ makeFunction $ do
(field :: Text) <- ask >>= getPositionalArg 1 >>= fromVal
defval <- namedArg "default" VNone
case F.toList cs of
[Elt _ _ fields] ->
case M.lookup (Identifier field) fields of
Just v -> pure v
Nothing -> pure defval
_ -> pure defval
"location" -> methodUnimplemented fld
"text" ->
case F.toList cs of
[Txt t] -> pure $ VString t
[Elt "text" _ [("body", VContent [Txt t])]] -> pure $ VString t
[Elt _ _ fields]
| Just x <- M.lookup "text" fields -> pure x
_ -> fail "Content is not a single text element"
"fields" -> pure $ makeFunction $ do
VDict <$>
case F.toList cs of
(Elt _ _ fields:_) -> pure $ OM.fromList $ M.toList fields
_ -> pure OM.empty
_ ->
let childrenOrFallback =
if fld == "children"
then
pure $
VArray $
V.fromList $
map (\x -> VContent [x]) $
F.toList cs
else noMethod "Content" fld
in case cs of
[Elt _name _ fields] ->
maybe childrenOrFallback pure $ M.lookup (Identifier fld) fields
_ -> childrenOrFallback
VTermItem t d ->
case fld of
"term" -> pure $ VContent t
"description" -> pure $ VContent d
_ -> noMethod "TermItem" fld
VVersion xs ->
case fld of
"at" -> pure $ makeFunction $ do
i <- nthArg 1
pure $ VInteger $ fromMaybe 0 $ listToMaybe $ drop i xs
_ -> noMethod "Version" fld
VArray v -> do
let toPos n =
if n < 0
then V.length v + n
else n
case fld of
"len" ->
pure $ makeFunction $ pure $ VInteger (fromIntegral $ V.length v)
"first" ->
pure $
makeFunction $
if V.null v
then fail "empty array"
else pure $ V.head v
"last" ->
pure $
makeFunction $
if V.null v
then fail "empty array"
else pure $ V.last v
"at" -> pure $ makeFunction $ do
pos <- toPos <$> nthArg 1
defval <- namedArg "default" VNone
pure $ fromMaybe defval $ v V.!? pos
"push" -> pure $ makeFunction $ do
x <- nthArg 1
lift $ updateVal $ VArray $ V.snoc v x
pure VNone
"pop" ->
pure $
makeFunction $
if V.null v
then fail "empty array"
else do
lift $ updateVal $ VArray $ V.init v
pure $ V.last v
"slice" -> pure $ makeFunction $ do
start <- toPos <$> nthArg 1
mbcount <- namedArg "count" Nothing
end <- (toPos <$> nthArg 2) `mplus`
pure (maybe (V.length v) (+ start) mbcount)
if V.length v < end
then fail "array contains insufficient elements for slice"
else
if end < start
then pure $ VArray mempty
else pure $ VArray $ V.slice start (end - start) v
"split" -> pure $ makeFunction $ do
spliton <- nthArg 1
let go v' = case V.break (== spliton) v' of
(a, b) | V.null b -> [VArray a | not (V.null a)]
(a, b) -> VArray a : go (V.drop 1 b)
pure $ VArray $ V.fromList $ go v
"intersperse" -> pure $ makeFunction $ do
sep <- nthArg 1
pure $ VArray . V.fromList . intersperse sep . V.toList $ v
"dedup" -> pure $ makeFunction $ do
pure $ VArray $ deduplicateVector v
"insert" -> pure $ makeFunction $ do
pos <- toPos <$> nthArg 1
newval <- nthArg 2
if pos >= V.length v || pos < 0
then fail "insert position out of bounds in array"
else do
lift $ updateVal $ VArray $ V.snoc (V.take pos v) newval <> V.drop pos v
pure VNone
"remove" -> pure $ makeFunction $ do
pos <- toPos <$> nthArg 1
if pos >= V.length v || pos < 0
then fail "remove position out of bounds in array"
else do
lift $ updateVal $ VArray $ V.take pos v <> V.drop (pos + 1) v
pure $ fromMaybe VNone $ v V.!? pos
"contains" -> pure $ makeFunction $ do
item <- nthArg 1
pure $ VBoolean $ V.elem item v
"find" -> pure $ makeFunction $ do
Function fn <- nthArg 1
let go Nothing y = do
res <- lift $ fn Arguments {positional = [y], named = OM.empty}
case res of
VBoolean True -> pure $ Just y
VBoolean False -> pure Nothing
_ -> fail "function does not return a boolean"
go (Just z) _ = pure $ Just z
res <- foldM go Nothing v
case res of
Just z -> pure z
Nothing -> pure VNone
"position" -> pure $ makeFunction $ do
Function fn <- nthArg 1
let go (Left i) y = do
res <- lift $ fn Arguments {positional = [y], named = OM.empty}
case res of
VBoolean True -> pure $ Right i
VBoolean False -> pure $ Left (i + 1)
_ -> fail "function does not return a boolean"
go (Right i) _ = pure $ Right i
res <- foldM go (Left 0) v
case res of
Right i -> pure $ VInteger i
Left _ -> pure VNone
"filter" -> pure $ makeFunction $ do
Function fn <- nthArg 1
let predicate y = do
res <- lift $ fn Arguments {positional = [y], named = OM.empty}
case res of
VBoolean True -> pure True
VBoolean False -> pure False
_ -> fail "function does not return a boolean"
VArray <$> V.filterM predicate v
"map" -> pure $ makeFunction $ do
Function fn <- nthArg 1
let f y = lift $ fn Arguments {positional = [y], named = OM.empty}
VArray <$> V.mapM f v
"flatten" ->
pure $
makeFunction $
pure $
VArray $
V.concat [v' | VArray v' <- V.toList v]
"enumerate" ->
pure $
makeFunction $
pure $
VArray $
V.zipWith
(\x y -> VArray [x, y])
(V.map VInteger [0 .. (fromIntegral $ V.length v)])
v
"fold" -> pure $ makeFunction $ do
(start :: Val) <- nthArg 1
Function fn <- nthArg 2
let f acc y = fn Arguments {positional = [acc, y], named = OM.empty}
lift $ foldM f start $ V.toList v
"reduce" -> pure $ makeFunction $ do
Function fn <- nthArg 1
let f acc y = fn Arguments {positional = [acc, y], named = OM.empty}
case V.toList v of
[] -> pure VNone
(x:xs) -> lift $ foldM f x xs
"any" -> pure $ makeFunction $ do
Function fn <- nthArg 1
let predicate y = do
res <- lift $ fn Arguments {positional = [y], named = OM.empty}
case res of
VBoolean True -> pure True
VBoolean False -> pure False
_ -> fail "function not return a boolean"
(VBoolean . V.any id) <$> mapM predicate v
"all" -> pure $ makeFunction $ do
Function fn <- nthArg 1
let predicate y = do
res <- lift $ fn Arguments {positional = [y], named = OM.empty}
case res of
VBoolean True -> pure True
VBoolean False -> pure False
_ -> fail "function not return a boolean"
(VBoolean . V.all id) <$> mapM predicate v
"rev" -> pure $ makeFunction $ pure $ VArray $ V.reverse v
"join" -> pure $ makeFunction $ do
separator <- nthArg 1
lastsep <- namedArg "last" separator
let xs' = F.toList v
let xs = case xs' of
[] -> []
_ -> intersperse separator (init xs') ++ [lastsep, last xs']
foldM joinVals VNone xs
"sorted" -> pure $ makeFunction $ do
(mbKeyFn :: Maybe Function) <- namedArg "key" Nothing
case mbKeyFn of
Nothing -> pure $ VArray $ V.fromList $ sort $ V.toList v
Just (Function kf) -> do
let kf' x = lift $ kf Arguments {positional = [x], named = OM.empty}
VArray . V.fromList . map fst . sortOn snd
<$> (mapM (\x -> (x,) <$> kf' x) (V.toList v))
"zip" -> pure $ makeFunction $ do
(xs :: [Val]) <- positional <$> ask
let len = V.length v
pure $ VArray $ V.filter (/= VNone) $
V.map (\i -> maybe VNone (VArray . V.fromList)
(mapM (\x ->
case x of
VArray v' -> v' V.!? i
_ -> Nothing) (val : xs)))
(V.enumFromTo 0 (len - 1))
"to-dict" -> pure $ makeFunction $
VDict . OM.fromList <$>
mapM (\x -> do
vx <- fromVal x
case V.toList vx of
[a,b] -> do
k <- fromVal a
pure (Identifier k, b)
_ -> fail "vector has wrong shape") (V.toList v)
"windows" -> pure $ makeFunction $ do
(windowsize :: Int) <- nthArg 1
case V.length v - windowsize of
n | n < 0 -> pure $ VArray mempty
| otherwise -> pure $ VArray $ V.fromList $
map (\x -> VArray $ V.take windowsize $ V.drop x v) [0..n]
"sum" -> pure $ makeFunction $ do
mbv <- namedArg "default" Nothing
case V.uncons v of
Nothing ->
maybe
(fail "sum of empty array with no default value")
pure
mbv
Just (h, rest) ->
pure $
fromMaybe VNone $
V.foldl
( \mbsum x -> case mbsum of
Nothing -> Nothing
Just y -> maybePlus y x
)
(Just h)
rest
"product" -> pure $ makeFunction $ do
mbv <- namedArg "default" Nothing
case V.uncons v of
Nothing ->
maybe
(fail "product of empty array with no default value")
pure
mbv
Just (h, rest) ->
pure $
fromMaybe VNone $
V.foldl
( \mbsum x -> case mbsum of
Nothing -> Nothing
Just y -> maybeTimes y x
)
(Just h)
rest
_ -> noMethod "Array" fld
VFunction mbName scope (Function f) ->
case fld of
"with" -> pure $ makeFunction $ do
args <- ask
pure $
VFunction mbName scope $
Function $
\args' -> f (args <> args')
"where" -> pure $ makeFunction $ do
args <- ask
case mbName of
Nothing -> fail "function is not an element function"
Just name ->
pure $
VSelector $
SelectElement name (OM.assocs (named args))
_ -> noMethod "Function" fld
VSelector sel ->
case fld of
"or" -> pure $ makeFunction $ do
(other :: Selector) <- nthArg 1
pure $ VSelector $ SelectOr other sel
"and" -> pure $ makeFunction $ do
(other :: Selector) <- nthArg 1
pure $ VSelector $ SelectAnd other sel
"before" -> pure $ makeFunction $ do
(other :: Selector) <- nthArg 1
pure $ VSelector $ SelectBefore other sel
"after" -> pure $ makeFunction $ do
(other :: Selector) <- nthArg 1
pure $ VSelector $ SelectAfter other sel
_ -> noMethod "Selector" fld
VArguments args ->
case fld of
"pos" -> pure $ makeFunction $ pure $ VArray $ V.fromList (positional args)
"at" ->
pure $ makeFunction $ do
(x :: Val) <- nthArg 1
defval <- namedArg "default" VNone
case x of
VInteger{} -> do
i <- fromVal x
case positional args of
xs | i < length xs -> pure $ xs !! i
| otherwise -> pure defval
VString t ->
case OM.lookup (Identifier t) (named args) of
Just a -> pure a
Nothing -> pure defval
_ -> pure defval
"named" -> pure $ makeFunction $ pure $ VDict $ named args
_ -> noMethod "Arguments" fld
VDateTime mbdate mbtime -> do
let toSeconds = (floor :: Double -> Integer) . realToFrac
case fld of
"year" -> pure $ makeFunction $
pure $ case toGregorian <$> mbdate of
Nothing -> VNone
Just (y,_,_) -> VInteger (fromIntegral y)
"month" -> pure $ makeFunction $
pure $ case toGregorian <$> mbdate of
Nothing -> VNone
Just (_,m,_) -> VInteger (fromIntegral m)
"day" -> pure $ makeFunction $
pure $ case toGregorian <$> mbdate of
Nothing -> VNone
Just (_,_,d) -> VInteger (fromIntegral d)
"weekday" -> pure $ makeFunction $
pure $ case dayOfWeek <$> mbdate of
Nothing -> VNone
Just d-> VInteger (fromIntegral $ fromEnum d)
"hour" -> pure $ makeFunction $
pure $ case toSeconds <$> mbtime of
Nothing -> VNone
Just t -> VInteger $ t `div` 3600
"minute" -> pure $ makeFunction $
pure $ case toSeconds <$> mbtime of
Nothing -> VNone
Just t -> VInteger $ (t `mod` 3600) `div` 60
"second" -> pure $ makeFunction $
pure $ case toSeconds <$> mbtime of
Nothing -> VNone
Just t -> VInteger $ t `mod` 60
"display" -> pure $ makeFunction $ do
mbfmt <- nthArg 1 `mplus` pure Nothing
mbformat <- case mbfmt of
Nothing -> pure Nothing
Just fmt ->
case toTimeFormat <$> parseDisplayFormat fmt of
Left e -> fail $ "Could not parse display format: " <> show e
Right f -> pure $ Just f
pure $ VString $ T.pack $
case (mbdate, mbtime) of
(Nothing, Just t) -> formatTime defaultTimeLocale (fromMaybe "%X" mbformat) t
(Just d, Nothing) -> formatTime defaultTimeLocale (fromMaybe "%F" mbformat) d
(Nothing, Nothing) -> ""
(Just d, Just t) -> formatTime defaultTimeLocale (fromMaybe "%X %F" mbformat)
(UTCTime d t)
_ -> noMethod "DateTime" fld
_ -> noMethod (drop 1 $ takeWhile (/= ' ') $ show val) fld
formatNumber :: Text -> Int -> Text
formatNumber t n = F.foldMap go $ T.unpack t
where
go '1' | n >= 0 = T.pack (show n)
go 'a' | n >= 1 = T.singleton $ cycle ['a' .. 'z'] !! (n - 1 `mod` 26)
go 'A' | n >= 1 = T.singleton $ cycle ['A' .. 'Z'] !! (n - 1 `mod` 26)
go 'i' | n >= 1 = T.toLower $ toRomanNumeral n
go 'I' | n >= 1 = toRomanNumeral n
go 'い' | n >= 1 = T.pack (show n) -- TODO
go 'イ' | n >= 1 = T.pack (show n) -- TODO
go 'א' | n >= 1 = T.pack (show n) -- TODO
go '*'
| n >= 1 =
T.singleton $ cycle ['*', '†', '‡', '§', '¶', '‖'] !! (n - 1 `mod` 6)
| otherwise = "-"
go c = T.singleton c
toRomanNumeral :: Int -> T.Text
toRomanNumeral x
| x >= 4000 || x < 0 = "?"
| x >= 1000 = "M" <> toRomanNumeral (x - 1000)
| x >= 900 = "CM" <> toRomanNumeral (x - 900)
| x >= 500 = "D" <> toRomanNumeral (x - 500)
| x >= 400 = "CD" <> toRomanNumeral (x - 400)
| x >= 100 = "C" <> toRomanNumeral (x - 100)
| x >= 90 = "XC" <> toRomanNumeral (x - 90)
| x >= 50 = "L" <> toRomanNumeral (x - 50)
| x >= 40 = "XL" <> toRomanNumeral (x - 40)
| x >= 10 = "X" <> toRomanNumeral (x - 10)
| x == 9 = "IX"
| x >= 5 = "V" <> toRomanNumeral (x - 5)
| x == 4 = "IV"
| x >= 1 = "I" <> toRomanNumeral (x - 1)
| otherwise = ""
-- parser for DateTime display format
data FormatPart =
Literal String
| Variable String [(String, String)]
deriving Show
parseDisplayFormat :: String -> Either ParseError [FormatPart]
parseDisplayFormat = parse (many pFormatPart <* eof) ""
pFormatPart :: Parser FormatPart
pFormatPart = pVariable <|> pLiteral
pLiteral :: Parser FormatPart
pLiteral = Literal <$> many1 (satisfy (/='['))
pVariable :: Parser FormatPart
pVariable = do
void $ char '['
name <- many1 letter
spaces
modifiers <- many pModifier
void $ char ']'
pure $ Variable name modifiers
pModifier :: Parser (String, String)
pModifier = do
name <- many1 letter
void $ char ':'
spaces
val <- many1 alphaNum
spaces
pure (name, val)
-- convert formatparts into Data.Time format string
toTimeFormat :: [FormatPart] -> String
toTimeFormat = concatMap toTimeFormatPart
toTimeFormatPart :: FormatPart -> String
toTimeFormatPart (Literal s) = foldr esc "" s
where
esc '%' = ("%%" ++)
esc '\t' = ("%t" ++)
esc '\n' = ("%n" ++)
esc c = (c:)
toTimeFormatPart (Variable "year" mods) =
withPadding mods $
case lookup "repr" mods of
Just "last_two" -> "y"
_ -> "Y"
toTimeFormatPart (Variable "month" mods) =
withPadding mods $
case lookup "repr" mods of
Just "numerical" -> "%m"
Just "long" -> "b"
Just "short" -> "h"
_ -> "m"
toTimeFormatPart (Variable "day" mods) =
case lookup "padding" mods of
Just "space" -> "%e"
Just "zero" -> "%d"
_ -> "%e"
toTimeFormatPart (Variable "week_number" mods) =
withPadding mods $
case lookup "repr" mods of
Just "ISO" -> "V"
Just "sunday" -> "U"
Just "monday" -> "W"
_ -> "V"
toTimeFormatPart (Variable "weekday" mods) =
withPadding mods $
case lookup "repr" mods of
Just "long" -> "A"
Just "short" -> "a"
Just "sunday" -> "w"
Just "monday" -> "u"
_ -> ""
toTimeFormatPart (Variable "hour" mods) =
case lookup "hour" mods of
Just "24" | lookup "padding" mods == Just "zero" -> "%H"
| otherwise -> "%k"
Just "12" | lookup "padding" mods == Just "zero" -> "%I"
| otherwise -> "%l"
_ -> "%k"
toTimeFormatPart (Variable "period" mods) =
case lookup "case" mods of
Just "lower" -> "%P"
_ -> "%p"
toTimeFormatPart (Variable "minute" _) = "%M"
toTimeFormatPart (Variable "second" _) = "%S"
toTimeFormatPart _ = "?"
withPadding :: [(String, String)] -> String -> String
withPadding mods s = '%' :
case lookup "padding" mods of
Just "zero" -> '0' : s
Just "space" -> '_' : s
_ -> s
deduplicateVector :: Eq a => V.Vector a -> V.Vector a
deduplicateVector =
V.foldl' (\acc x -> if x `V.elem` acc then acc else acc `V.snoc` x) mempty