content: {-# 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
  