{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeSpec] -> ShowS
$cshowList :: [TypeSpec] -> ShowS
show :: TypeSpec -> String
$cshow :: TypeSpec -> String
showsPrec :: Int -> TypeSpec -> ShowS
$cshowsPrec :: Int -> TypeSpec -> ShowS
Show, TypeSpec -> TypeSpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeSpec -> TypeSpec -> Bool
$c/= :: TypeSpec -> TypeSpec -> Bool
== :: TypeSpec -> TypeSpec -> Bool
$c== :: 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 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 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 (forall a. a -> Maybe a
Just Identifier
qname) Map Identifier Val
scope forall a b. (a -> b) -> a -> b
$
      (forall (m :: * -> *). Monad m => Arguments -> MP m Val)
-> Function
Function forall a b. (a -> b) -> a -> b
$ \Arguments
args -> do
        SourcePos
pos <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
        Map Identifier Val
fields <- forall (m :: * -> *).
MonadFail m =>
[(Identifier, TypeSpec)] -> Arguments -> m (Map Identifier Val)
argsToFields [(Identifier, TypeSpec)]
specs Arguments
args
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Seq Content -> Val
VContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Seq a
Seq.singleton forall a b. (a -> b) -> a -> b
$ Identifier -> Maybe SourcePos -> Map Identifier Val -> Content
Elt Identifier
qname (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 forall a. Semigroup a => a -> a -> a
<> 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' =
  forall k v. OMap k v -> Map k v
OM.toMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments -> OMap Identifier Val
named forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM 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 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 forall a. Monoid a => a
mempty
    toType ValType
TTermItem Val
_ = Seq Content -> Seq Content -> Val
VTermItem forall a. Monoid a => a
mempty 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (ValType -> Val -> Bool
hasType' ValType
ty) (Arguments -> [Val]
positional Arguments
args)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        Arguments
args
          { named :: OMap Identifier Val
named =
              forall k v. Ord k => k -> v -> OMap k v -> OMap k v
insertOM
                Identifier
posname
                (Vector Val -> Val
VArray forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ValType -> Val -> Val
toType ValType
ty) [Val]
as)
                (Arguments -> OMap Identifier Val
named Arguments
args),
            positional :: [Val]
positional = [Val]
bs
          }
    go Arguments
args (Identifier
posname, One ValType
ty) =
      case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (ValType -> Val -> Bool
hasType' ValType
ty) (Arguments -> [Val]
positional Arguments
args) of
        ([], []) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Arguments
args
        ([Val]
as, Val
b : [Val]
bs) ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            Arguments
args
              { named :: OMap Identifier Val
named = forall k v. Ord k => k -> v -> OMap k v -> OMap k v
insertOM Identifier
posname (ValType -> Val -> Val
toType ValType
ty Val
b) (Arguments -> OMap Identifier Val
named Arguments
args),
                positional :: [Val]
positional = [Val]
as forall a. [a] -> [a] -> [a]
++ [Val]
bs
              }
        ([Val]
_, []) ->
          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 forall a. Maybe a
Nothing forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). Monad m => Arguments -> MP m Val)
-> Function
Function forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT 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 forall a. Maybe a
Nothing Map Identifier Val
m forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). Monad m => Arguments -> MP m Val)
-> Function
Function forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT 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 = forall (m :: * -> *).
Monad m =>
Int -> ReaderT Arguments (MP m) Val
getPositional (Int
num forall a. Num a => a -> a -> a
- Int
1) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *).
(FromVal a, 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Arguments -> [Val]
positional
  if Int
idx forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Val]
xs
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure Val
VNone
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Val]
xs forall a. [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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Arguments -> OMap Identifier Val
named
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 ->
  ReaderT Arguments (MP m) a
namedArg :: forall (m :: * -> *) a.
(Monad m, FromVal a) =>
Identifier -> ReaderT Arguments (MP m) a
namedArg ident :: Identifier
ident@(Identifier Text
ident') = do
  Maybe Val
mbval <- forall (m :: * -> *).
Monad m =>
Identifier -> ReaderT Arguments (MP m) (Maybe Val)
getNamed Identifier
ident
  case Maybe Val
mbval of
    Just Val
val -> forall a (m :: * -> *).
(FromVal a, MonadPlus m, MonadFail m) =>
Val -> m a
fromVal Val
val
    Maybe Val
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"named argument " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
ident' forall a. Semigroup a => a -> a -> a
<> String
" not defined"

allArgs :: Monad m => ReaderT Arguments (MP m) [Val]
allArgs :: forall (m :: * -> *). Monad m => ReaderT Arguments (MP m) [Val]
allArgs = 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Identifier Symbol
-> (Text, Bool, Text) -> Map Identifier Symbol
go 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 (forall a. Eq a => a -> a -> Bool
== Char
'.') Text
name of
        [] -> Map Identifier Symbol
m
        (Text
k : [Text]
ks) ->
          forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter
            ( \case
                Maybe Symbol
Nothing ->
                  forall a. a -> Maybe a
Just 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 forall a. Monoid a => a
mempty)
                Just (Symbol Text
dv Bool
da [(Set Text, Text)]
vs) ->
                  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Bool -> [(Set Text, Text)] -> Symbol
Symbol Text
dv Bool
da ([Text] -> Text -> [(Set Text, Text)] -> [(Set Text, Text)]
addVariant [Text]
ks Text
v [(Set Text, Text)]
vs)
            )
            (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 = ((forall a. Ord a => [a] -> Set a
Set.fromList [Text]
ks, Text
v) forall a. a -> [a] -> [a]
:)