{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Typst.Util
  ( TypeSpec (..),
    makeElement,
    makeElementWithScope,
    makeFunction,
    makeFunctionWithScope,
    makeSymbolMap,
    argsToFields,
    nthArg,
    namedArg,
    allArgs
  )
where

import Control.Monad (foldM)
import Control.Monad.Reader (ReaderT (runReaderT), asks)
import Data.List (foldl')
import qualified Data.Map as M
import qualified Data.Map.Ordered as OM
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import Text.Parsec (getPosition)
import Typst.Types

data TypeSpec
  = One ValType
  | Many ValType
  deriving (Int -> TypeSpec -> ShowS
[TypeSpec] -> ShowS
TypeSpec -> String
(Int -> TypeSpec -> ShowS)
-> (TypeSpec -> String) -> ([TypeSpec] -> ShowS) -> Show TypeSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeSpec -> ShowS
showsPrec :: Int -> TypeSpec -> ShowS
$cshow :: TypeSpec -> String
show :: TypeSpec -> String
$cshowList :: [TypeSpec] -> ShowS
showList :: [TypeSpec] -> ShowS
Show, TypeSpec -> TypeSpec -> Bool
(TypeSpec -> TypeSpec -> Bool)
-> (TypeSpec -> TypeSpec -> Bool) -> Eq TypeSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypeSpec -> TypeSpec -> Bool
== :: TypeSpec -> TypeSpec -> Bool
$c/= :: TypeSpec -> TypeSpec -> Bool
/= :: TypeSpec -> TypeSpec -> Bool
Eq)

insertOM :: Ord k => k -> v -> OM.OMap k v -> OM.OMap k v
insertOM :: forall k v. Ord k => k -> v -> OMap k v -> OMap k v
insertOM k
k v
v OMap k v
m = OMap k v
m OMap k v -> (k, v) -> OMap k v
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OM.|> (k
k, v
v)

-- | Create element function with names for positional parameters.
makeElement :: Maybe Identifier -> Identifier -> [(Identifier, TypeSpec)] -> (Identifier, Val)
makeElement :: Maybe Identifier
-> Identifier -> [(Identifier, TypeSpec)] -> (Identifier, Val)
makeElement Maybe Identifier
mbNamespace Identifier
name [(Identifier, TypeSpec)]
specs =
  Maybe Identifier
-> Identifier
-> [(Identifier, TypeSpec)]
-> Map Identifier Val
-> (Identifier, Val)
makeElementWithScope Maybe Identifier
mbNamespace Identifier
name [(Identifier, TypeSpec)]
specs Map Identifier Val
forall a. Monoid a => a
mempty

-- | Create element function with names for positional parameters.
makeElementWithScope ::
  Maybe Identifier ->
  Identifier ->
  [(Identifier, TypeSpec)] ->
  M.Map Identifier Val ->
  (Identifier, Val)
makeElementWithScope :: Maybe Identifier
-> Identifier
-> [(Identifier, TypeSpec)]
-> Map Identifier Val
-> (Identifier, Val)
makeElementWithScope Maybe Identifier
mbNamespace Identifier
name [(Identifier, TypeSpec)]
specs Map Identifier Val
scope =
  ( Identifier
name,
    Maybe Identifier -> Map Identifier Val -> Function -> Val
VFunction (Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
qname) Map Identifier Val
scope (Function -> Val) -> Function -> Val
forall a b. (a -> b) -> a -> b
$
      (forall (m :: * -> *). Monad m => Arguments -> MP m Val)
-> Function
Function ((forall (m :: * -> *). Monad m => Arguments -> MP m Val)
 -> Function)
-> (forall (m :: * -> *). Monad m => Arguments -> MP m Val)
-> Function
forall a b. (a -> b) -> a -> b
$ \Arguments
args -> do
        SourcePos
pos <- ParsecT [Markup] (EvalState m) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
        Map Identifier Val
fields <- [(Identifier, TypeSpec)]
-> Arguments
-> ParsecT [Markup] (EvalState m) m (Map Identifier Val)
forall (m :: * -> *).
MonadFail m =>
[(Identifier, TypeSpec)] -> Arguments -> m (Map Identifier Val)
argsToFields [(Identifier, TypeSpec)]
specs Arguments
args
        Val -> MP m Val
forall a. a -> ParsecT [Markup] (EvalState m) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> MP m Val) -> Val -> MP m Val
forall a b. (a -> b) -> a -> b
$ Seq Content -> Val
VContent (Seq Content -> Val) -> (Content -> Seq Content) -> Content -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> Seq Content
forall a. a -> Seq a
Seq.singleton (Content -> Val) -> Content -> Val
forall a b. (a -> b) -> a -> b
$ Identifier -> Maybe SourcePos -> Map Identifier Val -> Content
Elt Identifier
qname (SourcePos -> Maybe SourcePos
forall a. a -> Maybe a
Just SourcePos
pos) Map Identifier Val
fields
  )
  where
    qname :: Identifier
qname = case Maybe Identifier
mbNamespace of
      Maybe Identifier
Nothing -> Identifier
name
      Just Identifier
ns -> Identifier
ns Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
"." Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
name

argsToFields ::
  MonadFail m =>
  [(Identifier, TypeSpec)] ->
  Arguments ->
  m (M.Map Identifier Val)
argsToFields :: forall (m :: * -> *).
MonadFail m =>
[(Identifier, TypeSpec)] -> Arguments -> m (Map Identifier Val)
argsToFields [(Identifier, TypeSpec)]
specs Arguments
args' =
  OMap Identifier Val -> Map Identifier Val
forall k v. OMap k v -> Map k v
OM.toMap (OMap Identifier Val -> Map Identifier Val)
-> (Arguments -> OMap Identifier Val)
-> Arguments
-> Map Identifier Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments -> OMap Identifier Val
named (Arguments -> Map Identifier Val)
-> m Arguments -> m (Map Identifier Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Arguments -> (Identifier, TypeSpec) -> m Arguments)
-> Arguments -> [(Identifier, TypeSpec)] -> m Arguments
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Arguments -> (Identifier, TypeSpec) -> m Arguments
forall {f :: * -> *}.
Applicative f =>
Arguments -> (Identifier, TypeSpec) -> f Arguments
go Arguments
args' [(Identifier, TypeSpec)]
specs
  where
    hasType' :: ValType -> Val -> Bool
hasType' ValType
TContent VContent {} = Bool
True
    hasType' ValType
TContent VString {} = Bool
True
    hasType' ValType
TContent VSymbol {} = Bool
True
    hasType' ValType
TString (VContent Seq Content
_) = Bool
True
    hasType' ValType
TTermItem VArray {} = Bool
True
    hasType' ValType
x Val
y = ValType -> Val -> Bool
hasType ValType
x Val
y
    toType :: ValType -> Val -> Val
toType ValType
TContent Val
x = Seq Content -> Val
VContent (Seq Content -> Val) -> Seq Content -> Val
forall a b. (a -> b) -> a -> b
$ Val -> Seq Content
valToContent Val
x
    toType ValType
TTermItem (VArray [VContent Seq Content
t, VContent Seq Content
d]) = Seq Content -> Seq Content -> Val
VTermItem Seq Content
t Seq Content
d
    toType ValType
TTermItem (VArray [VContent Seq Content
t]) = Seq Content -> Seq Content -> Val
VTermItem Seq Content
t Seq Content
forall a. Monoid a => a
mempty
    toType ValType
TTermItem Val
_ = Seq Content -> Seq Content -> Val
VTermItem Seq Content
forall a. Monoid a => a
mempty Seq Content
forall a. Monoid a => a
mempty
    toType ValType
TLabel (VContent [Lab Text
t]) = Text -> Val
VLabel Text
t
    toType ValType
_ Val
x = Val
x
    go :: Arguments -> (Identifier, TypeSpec) -> f Arguments
go Arguments
args (Identifier
posname, Many ValType
ty) = do
      let ([Val]
as, [Val]
bs) = (Val -> Bool) -> [Val] -> ([Val], [Val])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (ValType -> Val -> Bool
hasType' ValType
ty) (Arguments -> [Val]
positional Arguments
args)
      Arguments -> f Arguments
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arguments -> f Arguments) -> Arguments -> f Arguments
forall a b. (a -> b) -> a -> b
$
        Arguments
args
          { named =
              insertOM
                posname
                (VArray $ V.fromList $ map (toType ty) as)
                (named args),
            positional = bs
          }
    go Arguments
args (Identifier
posname, One ValType
ty) =
      case (Val -> Bool) -> [Val] -> ([Val], [Val])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (ValType -> Val -> Bool
hasType' ValType
ty) (Arguments -> [Val]
positional Arguments
args) of
        ([], []) -> Arguments -> f Arguments
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Arguments
args
        ([Val]
as, Val
b : [Val]
bs) ->
          Arguments -> f Arguments
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arguments -> f Arguments) -> Arguments -> f Arguments
forall a b. (a -> b) -> a -> b
$
            Arguments
args
              { named = insertOM posname (toType ty b) (named args),
                positional = as ++ bs
              }
        ([Val]
_, []) ->
          Arguments -> f Arguments
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Arguments
args

makeFunction ::
  (forall m'. Monad m' => ReaderT Arguments (MP m') Val) -> Val
makeFunction :: (forall (m' :: * -> *). Monad m' => ReaderT Arguments (MP m') Val)
-> Val
makeFunction forall (m' :: * -> *). Monad m' => ReaderT Arguments (MP m') Val
f = Maybe Identifier -> Map Identifier Val -> Function -> Val
VFunction Maybe Identifier
forall a. Maybe a
Nothing Map Identifier Val
forall a. Monoid a => a
mempty (Function -> Val) -> Function -> Val
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). Monad m => Arguments -> MP m Val)
-> Function
Function ((forall (m :: * -> *). Monad m => Arguments -> MP m Val)
 -> Function)
-> (forall (m :: * -> *). Monad m => Arguments -> MP m Val)
-> Function
forall a b. (a -> b) -> a -> b
$ ReaderT Arguments (ParsecT [Markup] (EvalState m) m) Val
-> Arguments -> ParsecT [Markup] (EvalState m) m Val
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Arguments (ParsecT [Markup] (EvalState m) m) Val
forall (m' :: * -> *). Monad m' => ReaderT Arguments (MP m') Val
f

makeFunctionWithScope ::
  (forall m'. Monad m' => ReaderT Arguments (MP m') Val) ->
  M.Map Identifier Val ->
  Val
makeFunctionWithScope :: (forall (m' :: * -> *). Monad m' => ReaderT Arguments (MP m') Val)
-> Map Identifier Val -> Val
makeFunctionWithScope forall (m' :: * -> *). Monad m' => ReaderT Arguments (MP m') Val
f Map Identifier Val
m = Maybe Identifier -> Map Identifier Val -> Function -> Val
VFunction Maybe Identifier
forall a. Maybe a
Nothing Map Identifier Val
m (Function -> Val) -> Function -> Val
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). Monad m => Arguments -> MP m Val)
-> Function
Function ((forall (m :: * -> *). Monad m => Arguments -> MP m Val)
 -> Function)
-> (forall (m :: * -> *). Monad m => Arguments -> MP m Val)
-> Function
forall a b. (a -> b) -> a -> b
$ ReaderT Arguments (ParsecT [Markup] (EvalState m) m) Val
-> Arguments -> ParsecT [Markup] (EvalState m) m Val
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Arguments (ParsecT [Markup] (EvalState m) m) Val
forall (m' :: * -> *). Monad m' => ReaderT Arguments (MP m') Val
f

nthArg ::
  (Monad m, FromVal a) =>
  Int ->
  ReaderT Arguments (MP m) a
nthArg :: forall (m :: * -> *) a.
(Monad m, FromVal a) =>
Int -> ReaderT Arguments (MP m) a
nthArg Int
num = Int -> ReaderT Arguments (MP m) Val
forall (m :: * -> *).
Monad m =>
Int -> ReaderT Arguments (MP m) Val
getPositional (Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ReaderT Arguments (MP m) Val
-> (Val -> ReaderT Arguments (MP m) a)
-> ReaderT Arguments (MP m) a
forall a b.
ReaderT Arguments (MP m) a
-> (a -> ReaderT Arguments (MP m) b) -> ReaderT Arguments (MP m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Val -> ReaderT Arguments (MP m) a
forall a (m :: * -> *).
(FromVal a, MonadPlus m, MonadFail m) =>
Val -> m a
forall (m :: * -> *). (MonadPlus m, MonadFail m) => Val -> m a
fromVal

getPositional :: Monad m => Int -> ReaderT Arguments (MP m) Val
getPositional :: forall (m :: * -> *).
Monad m =>
Int -> ReaderT Arguments (MP m) Val
getPositional Int
idx = do
  [Val]
xs <- (Arguments -> [Val]) -> ReaderT Arguments (MP m) [Val]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Arguments -> [Val]
positional
  if Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Val] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Val]
xs
    then Val -> ReaderT Arguments (MP m) Val
forall a. a -> ReaderT Arguments (MP m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Val
VNone
    else Val -> ReaderT Arguments (MP m) Val
forall a. a -> ReaderT Arguments (MP m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> ReaderT Arguments (MP m) Val)
-> Val -> ReaderT Arguments (MP m) Val
forall a b. (a -> b) -> a -> b
$ [Val]
xs [Val] -> Int -> Val
forall a. HasCallStack => [a] -> Int -> a
!! Int
idx

getNamed :: Monad m => Identifier -> ReaderT Arguments (MP m) (Maybe Val)
getNamed :: forall (m :: * -> *).
Monad m =>
Identifier -> ReaderT Arguments (MP m) (Maybe Val)
getNamed Identifier
ident = do
  OMap Identifier Val
m <- (Arguments -> OMap Identifier Val)
-> ReaderT Arguments (MP m) (OMap Identifier Val)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Arguments -> OMap Identifier Val
named
  Maybe Val -> ReaderT Arguments (MP m) (Maybe Val)
forall a. a -> ReaderT Arguments (MP m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Val -> ReaderT Arguments (MP m) (Maybe Val))
-> Maybe Val -> ReaderT Arguments (MP m) (Maybe Val)
forall a b. (a -> b) -> a -> b
$ Identifier -> OMap Identifier Val -> Maybe Val
forall k v. Ord k => k -> OMap k v -> Maybe v
OM.lookup Identifier
ident OMap Identifier Val
m

namedArg ::
  (Monad m, FromVal a) =>
  Identifier ->
  a ->
  ReaderT Arguments (MP m) a
namedArg :: forall (m :: * -> *) a.
(Monad m, FromVal a) =>
Identifier -> a -> ReaderT Arguments (MP m) a
namedArg ident :: Identifier
ident@(Identifier Text
_) a
defaultVal = do
  Maybe Val
mbval <- Identifier -> ReaderT Arguments (MP m) (Maybe Val)
forall (m :: * -> *).
Monad m =>
Identifier -> ReaderT Arguments (MP m) (Maybe Val)
getNamed Identifier
ident
  case Maybe Val
mbval of
    Just Val
val -> Val -> ReaderT Arguments (MP m) a
forall a (m :: * -> *).
(FromVal a, MonadPlus m, MonadFail m) =>
Val -> m a
forall (m :: * -> *). (MonadPlus m, MonadFail m) => Val -> m a
fromVal Val
val
    Maybe Val
Nothing -> a -> ReaderT Arguments (MP m) a
forall a. a -> ReaderT Arguments (MP m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
defaultVal

allArgs :: Monad m => ReaderT Arguments (MP m) [Val]
allArgs :: forall (m :: * -> *). Monad m => ReaderT Arguments (MP m) [Val]
allArgs = (Arguments -> [Val]) -> ReaderT Arguments (MP m) [Val]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Arguments -> [Val]
positional

makeSymbolMap :: [(Text, Bool, Text)] -> M.Map Identifier Symbol
makeSymbolMap :: [(Text, Bool, Text)] -> Map Identifier Symbol
makeSymbolMap = (Map Identifier Symbol
 -> (Text, Bool, Text) -> Map Identifier Symbol)
-> Map Identifier Symbol
-> [(Text, Bool, Text)]
-> Map Identifier Symbol
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Identifier Symbol
-> (Text, Bool, Text) -> Map Identifier Symbol
go Map Identifier Symbol
forall a. Monoid a => a
mempty
  where
    go :: M.Map Identifier Symbol -> (Text, Bool, Text) -> M.Map Identifier Symbol
    go :: Map Identifier Symbol
-> (Text, Bool, Text) -> Map Identifier Symbol
go Map Identifier Symbol
m (Text
name, Bool
accent, Text
v) =
      case (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
name of
        [] -> Map Identifier Symbol
m
        (Text
k : [Text]
ks) ->
          (Maybe Symbol -> Maybe Symbol)
-> Identifier -> Map Identifier Symbol -> Map Identifier Symbol
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter
            ( \case
                Maybe Symbol
Nothing ->
                  Symbol -> Maybe Symbol
forall a. a -> Maybe a
Just (Symbol -> Maybe Symbol) -> Symbol -> Maybe Symbol
forall a b. (a -> b) -> a -> b
$ Text -> Bool -> [(Set Text, Text)] -> Symbol
Symbol Text
v Bool
accent ([Text] -> Text -> [(Set Text, Text)] -> [(Set Text, Text)]
addVariant [Text]
ks Text
v [(Set Text, Text)]
forall a. Monoid a => a
mempty)
                Just (Symbol Text
dv Bool
da [(Set Text, Text)]
vs) ->
                  Symbol -> Maybe Symbol
forall a. a -> Maybe a
Just (Symbol -> Maybe Symbol) -> Symbol -> Maybe Symbol
forall a b. (a -> b) -> a -> b
$ Text -> Bool -> [(Set Text, Text)] -> Symbol
Symbol Text
dv' Bool
da [(Set Text, Text)]
variants
                  where variants :: [(Set Text, Text)]
variants = [Text] -> Text -> [(Set Text, Text)] -> [(Set Text, Text)]
addVariant [Text]
ks Text
v [(Set Text, Text)]
vs
                        minModifiers :: Int
minModifiers = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((Set Text, Text) -> Int) -> [(Set Text, Text)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Set Text -> Int
forall a. Set a -> Int
Set.size (Set Text -> Int)
-> ((Set Text, Text) -> Set Text) -> (Set Text, Text) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Text, Text) -> Set Text
forall a b. (a, b) -> a
fst) [(Set Text, Text)]
variants
                        shortestVariants :: [(Set Text, Text)]
shortestVariants =
                          ((Set Text, Text) -> Bool)
-> [(Set Text, Text)] -> [(Set Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
minModifiers) (Int -> Bool)
-> ((Set Text, Text) -> Int) -> (Set Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Text -> Int
forall a. Set a -> Int
Set.size (Set Text -> Int)
-> ((Set Text, Text) -> Set Text) -> (Set Text, Text) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Text, Text) -> Set Text
forall a b. (a, b) -> a
fst) [(Set Text, Text)]
variants
                         -- "When displaying a symbol, Typst selects the first
                         -- from the variants that have all attached modifiers
                         -- and the minimum number of other modifiers."
                        dv' :: Text
dv' = case ((Set Text, Text) -> Text) -> [(Set Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Set Text, Text) -> Text
forall a b. (a, b) -> b
snd [(Set Text, Text)]
shortestVariants of
                                  [] -> Text
dv
                                  (Text
x:[Text]
_) -> Text
x
            )
            (Text -> Identifier
Identifier Text
k)
            Map Identifier Symbol
m
    addVariant ::
      [Text] ->
      Text ->
      [(Set.Set Text, Text)] ->
      [(Set.Set Text, Text)]
    addVariant :: [Text] -> Text -> [(Set Text, Text)] -> [(Set Text, Text)]
addVariant [Text]
ks Text
v = ([(Set Text, Text)] -> [(Set Text, Text)] -> [(Set Text, Text)]
forall a. [a] -> [a] -> [a]
++ [([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text]
ks, Text
v)])