typst-0.8.1: src/Typst/Evaluate.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Typst.Evaluate
( evaluateTypst,
valToContent,
)
where
import Control.Monad (MonadPlus (mplus), foldM, foldM_)
import Control.Monad.State (MonadTrans (lift))
import Data.List (intersperse, sortOn)
import Data.Foldable (toList)
import qualified Data.Map as M
import qualified Data.Map.Ordered as OM
import Data.Maybe (isJust, fromMaybe)
import Data.Sequence (Seq)
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.Text.Encoding as TE
import qualified Data.Vector as V
import GHC.Generics (Generic)
import System.FilePath (replaceFileName, takeBaseName,
takeFileName, takeDirectory, (</>))
import Text.Parsec
import Typst.Bind (destructuringBind)
import Typst.Constructors (getConstructor)
import Typst.Methods (getMethod)
import Typst.Module.Standard (loadFileText, standardModule, symModule, getPath)
import Typst.Module.Math (mathModule)
import Typst.MathClass (mathClassOf, MathClass(Relation))
import Typst.Parse (parseTypst)
import Typst.Regex (match)
import Typst.Show (applyShowRules)
import Typst.Syntax
import Typst.Types
import Typst.Util (makeFunction, nthArg)
import qualified Toml as Toml
import qualified Toml.Schema as Toml
-- import Debug.Trace
-- | Evaluate a parsed typst expression, evaluating the code and
-- replacing it with content.
evaluateTypst ::
Monad m =>
-- | Dictionary of functions for IO operations
Operations m ->
-- | Path of parsed content
FilePath ->
-- | Markup produced by 'parseTypst'
[Markup] ->
m (Either ParseError Content)
evaluateTypst operations fp =
runParserT
(do contents <- mconcat <$> many pContent <* eof
-- "All documents are automatically wrapped in a document element."
els <- element (Identifier "document")
Arguments {positional = [VContent contents],
named = []}
case toList els of
[e] -> pure e
_ -> fail "element returned something other than a singleton")
initialEvalState { evalOperations = operations,
evalLocalDir = takeDirectory fp }
fp
initialEvalState :: EvalState m
initialEvalState =
emptyEvalState { evalIdentifiers = [(BlockScope, mempty)]
, evalMathIdentifiers = [(BlockScope, mathModule <> symModule)]
, evalStandardIdentifiers = [(BlockScope, standardModule'')]
, evalPackageRoot = "."
}
where
standardModule' = M.insert "eval" evalFunction standardModule
standardModule'' = M.insert "std" (VModule "std" standardModule') standardModule'
evalFunction = makeFunction $ do
code :: Text <- nthArg 1
case parseTypst "eval" ("#{\n" <> code <> "\n}") of
Left e -> fail $ "eval: " <> show e
Right [Code _ expr] ->
-- run in Either monad so we can't access file system
case runParserT (evalExpr expr) initialEvalState "eval" [] of
Failure e -> fail $ "eval: " <> e
Success (Left e) -> fail $ "eval: " <> show e
Success (Right val) -> pure val
Right _ -> fail "eval: got something other than Code (should not happen)"
satisfyTok :: Monad m => (Markup -> Bool) -> MP m Markup
satisfyTok f = tokenPrim show showPos match'
where
showPos _oldpos (Code pos _) _ = pos
showPos oldpos _ _ = oldpos
match' x | f x = Just x
match' _ = Nothing
pContent :: Monad m => MP m (Seq Content)
pContent = (pTxt <|> pElt) >>= applyShowRules >>= addTextElement
applyShowRulesToVal :: Monad m => Val -> MP m Val
applyShowRulesToVal (VContent cs) = VContent <$> applyShowRules cs
applyShowRulesToVal x = pure x
addTextElement :: Monad m => Seq Content -> MP m (Seq Content)
addTextElement = foldM go mempty
where
go acc (Txt "") = pure acc
go acc (Txt t) = (acc <>) <$> element "text" (Arguments [VContent [Txt t]] OM.empty)
go acc x = pure (acc Seq.|> x)
isText :: Markup -> Bool
isText Text {} = True
isText Space = True
isText SoftBreak = True
isText Nbsp = True
isText Shy = True
isText EmDash = True
isText EnDash = True
isText Ellipsis = True
isText (Quote _) = True
isText _ = False
getText :: Markup -> Text
getText (Text t) = t
getText Space = " "
getText SoftBreak = "\n"
getText Nbsp = "\xa0"
getText Shy = "\xad"
getText EmDash = "\x2014"
getText EnDash = "\x2013"
getText Ellipsis = "\x2026"
getText (Quote c) = T.singleton c -- TODO localize
getText _ = ""
pTxt :: Monad m => MP m (Seq Content)
pTxt = do
mathMode <- evalMath <$> getState
txt <-
if mathMode
then getText <$> satisfyTok isText
else mconcat . map getText . setQuotes <$> many1 (satisfyTok isText)
pure $ Seq.singleton $ Txt txt
setQuotes :: [Markup] -> [Markup]
setQuotes [] = []
setQuotes (Quote '"' : x : rest)
| x == Space || x == SoftBreak = Quote '\x201D' : setQuotes (x : rest)
setQuotes (Quote '\'' : x : rest)
| x == Space || x == SoftBreak = Quote '\x201D' : setQuotes (x : rest)
setQuotes (x : Quote '"' : rest)
| x == Space || x == SoftBreak = x : Quote '\x201C' : setQuotes rest
setQuotes (x : Quote '\'' : rest)
| x == Space || x == SoftBreak = x : Quote '\x2018' : setQuotes rest
setQuotes (Text t1 : Quote '\'' : Text t2 : rest) =
Text t1 : Quote '\x2019' : setQuotes (Text t2 : rest)
setQuotes (Quote '"' : Text t : rest)
| t `notElem` ([")", ".", ",", ";", ":", "?", "!", "]"] :: [Text]) =
Quote '\x201C' : setQuotes (Text t : rest)
setQuotes (Quote '\'' : Text t : rest)
| t `notElem` ([")", ".", ",", ";", ":", "?", "!", "]"] :: [Text]) =
Quote '\x2018' : setQuotes (Text t : rest)
setQuotes (Quote '"' : rest) = Quote '\x201D' : setQuotes rest
setQuotes (Quote '\'' : rest) = Quote '\x2019' : setQuotes rest
setQuotes (x : xs) = x : setQuotes xs
pInnerContents :: Monad m => [Markup] -> MP m (Seq Content)
pInnerContents ms = do
oldInput <- getInput
oldPos <- getPosition
oldShowRules <- evalShowRules <$> getState
setInput ms
result <- mconcat <$> (many pContent <* eof)
setInput oldInput
setPosition oldPos
updateState $ \st -> st {evalShowRules = oldShowRules}
pure result
single :: Content -> Seq Content
single = Seq.singleton
applyElementFunction :: Monad m => Identifier -> Function -> Arguments -> MP m Val
applyElementFunction name (Function f) args = do
-- lookup styles set by "set" and apply them as defaults:
mbSty <- M.lookup name . evalStyles <$> getState
f $ maybe args (<> args) mbSty
element :: Monad m => Identifier -> Arguments -> MP m (Seq Content)
element name@(Identifier n) args = do
eltfn <- lookupIdentifier name
case eltfn of
VFunction Nothing _ (Function f) -> valToContent <$> f args
VFunction (Just i) _ (Function f) ->
valToContent <$> applyElementFunction i (Function f) args
_ -> fail $ T.unpack n <> " is not an element function"
pElt :: Monad m => MP m (Seq Content)
pElt = do
tok <- satisfyTok (not . isText)
case tok of
ParBreak -> element "parbreak" mempty
HardBreak -> element "linebreak" mempty
Comment -> pure mempty
Code pos expr -> setPosition pos *> pExpr expr
Emph ms -> do
body <- pInnerContents ms
element "emph" Arguments {positional = [VContent body], named = OM.empty}
Strong ms -> do
body <- pInnerContents ms
element "strong" Arguments {positional = [VContent body], named = OM.empty}
Bracketed ms -> do
body <- pInnerContents ms
pure $ (Txt "[" Seq.<| body) Seq.|> Txt "]"
RawBlock lang txt ->
element
"raw"
Arguments
{ positional = [VString txt],
named =
OM.fromList
[ ("block", VBoolean True),
( "lang",
if T.null lang
then VNone
else VString lang
)
]
}
RawInline txt -> do
element
"raw"
Arguments
{ positional = [VString txt],
named =
OM.fromList
[ ("lang", VNone),
("block", VBoolean False)
]
}
Heading level ms -> do
content <- pInnerContents ms
element
"heading"
Arguments
{ positional = [VContent content],
named =
OM.fromList
[("level", VInteger (fromIntegral level))]
}
Equation display ms -> inBlock BlockScope $ do
oldMath <- evalMath <$> getState
updateState $ \st -> st {evalMath = True}
content <- pInnerContents ms
element
"equation"
Arguments
{ positional = [VContent content],
named =
OM.fromList
[ ("block", VBoolean display),
("numbering", VNone)
]
} <* updateState (\st -> st {evalMath = oldMath})
MFrac numexp denexp -> do
let handleParens (MGroup (Just "(") (Just ")") xs) = MGroup Nothing Nothing xs
handleParens x = x
num <- pInnerContents [handleParens numexp]
den <- pInnerContents [handleParens denexp]
element
"frac"
Arguments
{ positional = [VContent num, VContent den],
named = OM.empty
}
MAttach mbBottomExp mbTopExp baseExp -> do
base' <- pInnerContents [baseExp]
pos <- getPosition
let base =
case base' of
[Elt "text" mbpos [("body", VContent [Txt t])]]
| T.all ((== Relation) . mathClassOf ) t
-> [Elt "math.limits" mbpos
[("body", VContent base')]]
[Txt t] | T.all ((== Relation) . mathClassOf ) t
-> [Elt "math.limits" (Just pos)
[("body", VContent base')]]
_ -> base'
mbBottom <-
maybe
(pure Nothing)
(fmap Just . pInnerContents . (: []))
mbBottomExp
mbTop <-
maybe
(pure Nothing)
(fmap Just . pInnerContents . (: []))
mbTopExp
element
"attach"
Arguments
{ positional = [VContent base],
named =
OM.fromList
[ ("b", maybe VNone VContent mbBottom),
("t", maybe VNone VContent mbTop)
]
}
MGroup mbOp mbCl ms -> wrapIn mbOp mbCl <$> pInnerContents ms
MAlignPoint -> element "alignpoint" mempty
Ref ident supp -> do
supp' <- evalExpr supp
element
"ref"
Arguments
{ positional = [VLabel ident],
named =
OM.fromList
[ ( "supplement", supp' ) ]
}
BulletListItem ms -> do
skipMany $ satisfyTok isBreak
firstItem <- pInnerContents ms
-- parse a sequence of list items and put them in a list element
items <- (firstItem :) <$> many pListItem
element
"list"
Arguments
{ positional = map VContent items,
named = OM.empty
}
EnumListItem mbStart ms -> do
skipMany $ satisfyTok isBreak
firstItem <- pInnerContents ms
-- parse a sequence of list items and put them in a list element
items <- (firstItem :) <$> many pEnumItem
element
"enum"
Arguments
{ positional = map VContent items,
named =
maybe
OM.empty
( \x ->
OM.fromList
[("start", VInteger (fromIntegral x))]
)
mbStart
}
DescListItem ts ds -> do
ts' <- pInnerContents ts
ds' <- pInnerContents ds
skipMany (satisfyTok isBreak)
let firstItem = VArray [VContent ts', VContent ds']
items <- (firstItem :) <$> many pDescItem
element
"terms"
Arguments
{ positional = items,
named = OM.empty
}
Url t ->
element
"link"
Arguments
{ positional =
[ VString t,
VContent (Seq.singleton (Txt t))
],
named = OM.empty
}
_ -> fail $ "Encountered " <> show tok <> " in pElt"
pDescItem :: Monad m => MP m Val
pDescItem = do
tok <- satisfyTok isDescListItem
case tok of
DescListItem ts ds -> do
ts' <- pInnerContents ts
ds' <- pInnerContents ds
skipMany (satisfyTok isBreak)
pure $ VArray [VContent ts', VContent ds']
_ -> fail "pDescItem encountered non DescListItem"
where
isDescListItem DescListItem {} = True
isDescListItem _ = False
pEnumItem :: Monad m => MP m (Seq Content)
pEnumItem = do
tok <- satisfyTok isEnumListItem
case tok of
EnumListItem _ ms -> pInnerContents ms <* skipMany (satisfyTok isBreak)
_ -> fail "pEnumItem encountered non EnumListItem"
where
isEnumListItem EnumListItem {} = True
isEnumListItem _ = False
pListItem :: Monad m => MP m (Seq Content)
pListItem = do
tok <- satisfyTok isBulletListItem
case tok of
BulletListItem ms -> pInnerContents ms <* skipMany (satisfyTok isBreak)
_ -> fail "pListItem encountered non BulletListItem"
where
isBulletListItem BulletListItem {} = True
isBulletListItem _ = False
isBreak :: Markup -> Bool
isBreak SoftBreak = True
isBreak ParBreak = True
isBreak _ = False
wrapIn :: Maybe Text -> Maybe Text -> Seq Content -> Seq Content
wrapIn Nothing Nothing cs = cs
wrapIn (Just op) (Just cl) cs =
Seq.singleton $
Elt
"math.lr"
Nothing
[ ( "body",
VArray $
V.fromList
[VContent $ Txt op Seq.<| (cs Seq.|> Txt cl)]
)
]
wrapIn Nothing (Just cl) cs = cs Seq.|> Txt cl
wrapIn (Just op) Nothing cs = Txt op Seq.<| cs
pExpr :: Monad m => Expr -> MP m (Seq Content)
pExpr expr = valToContent <$> evalExpr expr
evalExpr :: Monad m => Expr -> MP m Val
evalExpr expr = applyShowRulesToVal =<<
case expr of
Literal lit -> pure $ evalLiteral lit
Group e -> evalExpr e
Block (Content ms) -> VContent <$> pInnerContents ms
Block (CodeBlock exprs) ->
inBlock BlockScope $
-- let, etc. inside block are isolated
-- we concat the results inside the block
fst
<$> foldM
( \(result, finished) e ->
if finished
then pure (result, finished)
else do
updateState $ \st -> st {evalFlowDirective = FlowNormal}
val <- evalExpr e
flow <- evalFlowDirective <$> getState
case flow of
FlowNormal -> do
combined <- joinVals result val
pure (combined, False)
FlowContinue -> do
combined <- joinVals result val
pure (combined, True)
FlowBreak -> do
combined <- joinVals result val
pure (combined, True)
FlowReturn True -> pure (val, True)
FlowReturn False -> do
combined <- joinVals result val
pure (combined, True)
)
(VNone, False)
exprs
Array es -> VArray <$> foldM
( \xs x ->
case x of
Spr y -> do
val <- evalExpr y
case val of
VArray ys -> pure (xs <> ys)
_ -> fail $ "Could not spread " <> show (valType val) <>
" into array"
Reg e -> do
val <- evalExpr e
pure (V.snoc xs val ) )
[]
es
Dict items ->
VDict
<$> foldM
( \m v -> do
case v of
Reg (k, e) -> do
k' <- case k of
Ident i -> pure i
_ -> do VString s <- evalExpr k
pure $ Identifier s
val <- evalExpr e
pure $ m OM.|> (k', val)
Spr y -> do
val <- evalExpr y
case val of
VDict m' -> pure (m' OM.|<> m)
_ -> fail $ "Could not spread " <> show (valType val) <>
" into dictionary"
)
OM.empty
items
Not e -> do
val <- evalExpr e
case val of
VBoolean b -> pure $ VBoolean (not b)
_ -> fail $ "Cannot apply 'not' to " <> show val
And e1 e2 -> do
val1 <- evalExpr e1
case val1 of
VBoolean False -> pure $ VBoolean False
VBoolean True -> do
val2 <- evalExpr e2
case val2 of
VBoolean True -> pure $ VBoolean True
VBoolean False -> pure $ VBoolean False
_ -> fail $ "Cannot apply 'and' to " <> show val1
_ -> fail $ "Cannot apply 'and' to " <> show val1
Or e1 e2 -> do
val1 <- evalExpr e1
case val1 of
VBoolean True -> pure $ VBoolean True
VBoolean False -> do
val2 <- evalExpr e2
case val2 of
VBoolean True -> pure $ VBoolean True
VBoolean False -> pure $ VBoolean False
_ -> fail $ "Cannot apply 'or' to " <> show val1
_ -> fail $ "Cannot apply 'or' to " <> show val1
Ident ident -> lookupIdentifier ident
Let bind e -> do
val <- evalExpr e
case bind of
BasicBind (Just ident) -> addIdentifier ident val
BasicBind Nothing -> pure ()
DestructuringBind parts -> destructuringBind addIdentifier parts val
pure VNone
LetFunc name params e -> do
val <- toFunction (Just name) params e
addIdentifier name val
pure VNone
FieldAccess (Ident (Identifier fld)) e -> do
val <- evalExpr e
getMethod (updateExpression e) val fld
<|> case val of
VSymbol (Symbol _ accent variants) -> do
let variants' =
sortOn (Set.size . fst) $
filter (\(var, _) -> fld `Set.member` var) variants
case variants' of
[] -> fail $ "Symbol does not have variant " <> show fld
((_, s) : _) -> pure $ VSymbol $ Symbol s accent variants'
VModule _ m ->
case M.lookup (Identifier fld) m of
Just x -> pure x
Nothing -> fail $ "Module does not contain " <> show fld
VFunction _ m _ ->
case M.lookup (Identifier fld) m of
Just x -> pure x
Nothing -> fail $ "Function scope does not contain " <> show fld
VDict m ->
case OM.lookup (Identifier fld) m of
Just x -> pure x
Nothing -> fail $ show (Identifier fld) <> " not found"
_ -> fail "FieldAccess requires a dictionary"
FieldAccess _ _ -> fail "FieldAccess requires an identifier"
FuncCall e args -> do
updateState $ \st -> st {evalFlowDirective = FlowNormal}
val <- evalExpr e
mathMode <- evalMath <$> getState
case val of
VFunction (Just i) _ (Function f) -> do
arguments <- toArguments args
applyElementFunction i (Function f) arguments
VFunction Nothing _ (Function f) -> toArguments args >>= f
VType ty ->
case getConstructor ty of
Just (VFunction _ _ (Function f)) -> toArguments args >>= f
_ -> fail $ "No constructor defined for type " <> show ty
VSymbol (Symbol _ True _) | mathMode ->
do
val' <- lookupIdentifier "accent"
case val' of
VFunction _ _ (Function f) ->
toArguments args
>>= f . (\a -> a {positional = positional a ++ [val]})
_ -> fail "accent not defined"
_
| mathMode -> do
args' <- toArguments args
pure $
VContent $
valToContent val
<> single "("
<> mconcat
( intersperse
(single ",")
(map valToContent (positional args'))
)
<> single ")"
| otherwise -> fail "Attempt to call a non-function"
FuncExpr params e -> toFunction Nothing params e
Equals e1 e2 -> do
v1 <- evalExpr e1
v2 <- evalExpr e2
case comp v1 v2 of
Just EQ -> pure $ VBoolean True
_ -> pure $ VBoolean False
LessThan e1 e2 -> do
v1 <- evalExpr e1
v2 <- evalExpr e2
case comp v1 v2 of
Nothing -> fail $ "Can't compare " <> show v1 <> " and " <> show v2
Just LT -> pure $ VBoolean True
_ -> pure $ VBoolean False
GreaterThan e1 e2 -> do
v1 <- evalExpr e1
v2 <- evalExpr e2
case comp v1 v2 of
Nothing -> fail $ "Can't compare " <> show v1 <> " and " <> show v2
Just GT -> pure $ VBoolean True
_ -> pure $ VBoolean False
LessThanOrEqual e1 e2 -> do
v1 <- evalExpr e1
v2 <- evalExpr e2
case comp v1 v2 of
Nothing -> fail $ "Can't compare " <> show e1 <> " and " <> show e2
Just LT -> pure $ VBoolean True
Just EQ -> pure $ VBoolean True
_ -> pure $ VBoolean False
GreaterThanOrEqual e1 e2 -> do
v1 <- evalExpr e1
v2 <- evalExpr e2
case comp v1 v2 of
Nothing -> fail $ "Can't compare " <> show v1 <> " and " <> show v2
Just GT -> pure $ VBoolean True
Just EQ -> pure $ VBoolean True
_ -> pure $ VBoolean False
InCollection e1 e2 -> do
v1 <- evalExpr e1
v2 <- evalExpr e2
case v2 of
VString t ->
case v1 of
VString t' -> pure $ VBoolean $ t' `T.isInfixOf` t
VRegex re -> pure $ VBoolean $ match re t
_ -> fail $ "Can't apply 'in' to " <> show v1 <> " and string"
VType ty ->
case v1 of
VString t' -> pure $ VBoolean $ t' `T.isInfixOf` (prettyType ty)
VRegex re -> pure $ VBoolean $ match re (prettyType ty)
_ -> fail $ "Can't apply 'in' to " <> show v1
VArray vec -> pure $ VBoolean $ V.elem v1 vec
VDict m ->
case v1 of
VString t -> pure $ VBoolean $ isJust $ OM.lookup (Identifier t) m
_ -> pure $ VBoolean False
_ -> fail $ "Can't apply 'in' to " <> show v2 <> show (e1,e2)
Negated e -> do
v <- evalExpr e
case maybeNegate v of
Nothing -> fail $ "Can't negate " <> show v
Just v' -> pure v'
Plus e1 e2 -> do
v1 <- evalExpr e1
v2 <- evalExpr e2
case (v1, v2) of
(VAlignment x1 y1, VAlignment x2 y2) ->
pure $ VAlignment (x1 `mplus` x2) (y1 `mplus` y2)
(VArguments xs, VArguments ys) ->
pure $ VArguments (xs <> ys)
_ -> case maybePlus v1 v2 of
Nothing -> fail $ "Can't + " <> show v1 <> " and " <> show v2
Just v -> pure v
Minus e1 e2 -> do
v1 <- evalExpr e1
v2 <- evalExpr e2
case maybeMinus v1 v2 of
Nothing -> fail $ "Can't - " <> show v1 <> " and " <> show v2
Just v -> pure v
Times e1 e2 -> do
v1 <- evalExpr e1
v2 <- evalExpr e2
case maybeTimes v1 v2 of
Nothing -> fail $ "Can't * " <> show v1 <> " and " <> show v2
Just v -> pure v
Divided e1 e2 -> do
v1 <- evalExpr e1
v2 <- evalExpr e2
case maybeDividedBy v1 v2 of
Nothing -> fail $ "Can't / " <> show v1 <> " and " <> show v2
Just v -> pure v
Set e args -> do
v <- evalExpr e
as' <- toArguments args
case v of
VFunction (Just name) _ _ ->
updateState $ \st ->
st
{ evalStyles =
M.alter
( \case
Nothing -> Just as'
Just as'' -> Just (as'' <> as')
)
name
$ evalStyles st
}
_ -> fail $ "Set expects an element name"
pure VNone
Show mbSelExpr e -> do
renderVal <- inBlock FunctionScope $ evalExpr e
case mbSelExpr of
Nothing -> do
rest <- mconcat <$> (many pContent <* eof)
case renderVal of
VFunction _ _ (Function f) ->
VContent . valToContent
<$> f Arguments {positional = [VContent rest], named = OM.empty}
_ -> pure $ VContent $ valToContent renderVal
Just selExpr -> do
selector <- evalExpr selExpr >>= toSelector
case renderVal of
VFunction _ _ (Function f) ->
updateState $ \st ->
st
{ evalShowRules =
ShowRule
(evalNextShowRuleIdentifier st)
selector
( \c ->
valToContent
<$> f
Arguments
{ positional = [VContent (Seq.singleton c)],
named = OM.empty
}
)
: evalShowRules st,
evalNextShowRuleIdentifier = evalNextShowRuleIdentifier st + 1
}
_ -> updateState $ \st ->
st
{ evalShowRules =
ShowRule
(evalNextShowRuleIdentifier st)
selector
( \c ->
case e of
-- ignore show set for now TODO
Set _ _ -> pure $ Seq.singleton c
_ -> pure (valToContent renderVal)
)
: evalShowRules st,
evalNextShowRuleIdentifier = evalNextShowRuleIdentifier st + 1
}
pure VNone
Binding _ -> fail $ "Encountered binding out of proper context"
Assign e1 e2 -> do
val <- evalExpr e2
case e1 of
Binding (BasicBind (Just ident)) -> updateIdentifier ident val
Binding (BasicBind Nothing) -> pure ()
Binding (DestructuringBind parts) ->
destructuringBind updateIdentifier parts val
x -> updateExpression x val
pure VNone
If clauses -> do
let go [] = pure VNone
go ((cond, e) : rest) = do
val <- evalExpr cond
case val of
VBoolean True -> evalExpr e
VBoolean False -> go rest
_ -> fail "If requires a boolean condition"
go clauses
While e1 e2 -> do
let go result = do
condval <- evalExpr e1
case condval of
VBoolean True -> do
val <- evalExpr e2
hadBreak <- (== FlowBreak) . evalFlowDirective <$> getState
joinVals result val >>= if hadBreak then pure else go
VBoolean False -> pure result
_ -> fail "While loop requires a boolean condition"
updateState $ \st -> st {evalFlowDirective = FlowNormal}
go VNone
For bind e1 e2 -> do
let go [] result = pure result
go (x : xs) result = do
case bind of
BasicBind (Just ident) -> addIdentifier ident x
BasicBind Nothing -> pure ()
DestructuringBind parts ->
destructuringBind addIdentifier parts x
val <- evalExpr e2
hadBreak <- (== FlowBreak) . evalFlowDirective <$> getState
joinVals result val >>= if hadBreak then pure else go xs
source <- evalExpr e1
items <- case source of
VString t -> pure $ map (VString . T.singleton) (T.unpack t)
VArray v -> pure $ V.toList v
VDict m ->
pure $
map
( \(Identifier k, v) ->
VArray (V.fromList [VString k, v])
)
(OM.assocs m)
_ -> fail $ "For expression requires an Array or Dictionary"
updateState $ \st -> st {evalFlowDirective = FlowNormal}
go items VNone
Context e -> do
evalExpr e -- TODO for now we just ignore "context"
Return mbe -> do
-- these flow directives are examined in CodeBlock
result <- maybe (pure VNone) evalExpr mbe
updateState (\st -> st {evalFlowDirective = FlowReturn (isJust mbe)})
pure result
Continue -> do
updateState (\st -> st {evalFlowDirective = FlowContinue})
pure VNone
Break -> do
updateState (\st -> st {evalFlowDirective = FlowBreak})
pure VNone
Label t -> pure $ VLabel t
Import e imports -> do
argval <- evalExpr e
(modid, modmap) <-
case argval of
VString t -> snd <$> loadModule t
VModule i m -> pure (i, m)
VFunction (Just i) m _ -> pure (i, m)
VFunction Nothing m _ -> pure ("anonymous", m)
_ -> fail "Import requires a path or module or function"
case imports of
AllIdentifiers -> importModule modmap
SomeIdentifiers pairs -> do
let addFromModule m (ident, mbAs) =
case M.lookup ident modmap of
Nothing -> fail $ show ident <> " not defined in module"
Just v -> pure $ M.insert (fromMaybe ident mbAs) v m
foldM addFromModule mempty pairs >>= importModule
NoIdentifiers mbAs -> do
let ident = fromMaybe modid mbAs
addIdentifier ident (VModule ident modmap)
pure VNone
Include e -> do
argval <- evalExpr e
case argval of
VString t -> do
(cs, _) <- loadModule t
pure $ VContent cs
_ -> fail "Include requires a path"
Underscore -> fail "expected expression, found underscore"
toFunction ::
Monad m =>
Maybe Identifier ->
[Param] ->
Expr ->
MP m Val
toFunction mbname params e = do
idents <- evalIdentifiers <$> getState
let fn = VFunction Nothing mempty $ Function $ \arguments -> do
-- set identifiers from params and arguments
let showIdentifier (Identifier i) = T.unpack i
let isSinkParam (SinkParam {}) = True
isSinkParam _ = False
let setParam as (DefaultParam ident e') = do
val <- case OM.lookup ident (named as) of
Nothing -> evalExpr e'
Just v -> pure v
addIdentifier ident val
pure $ as {named = OM.delete ident (named as)}
setParam as (NormalParam ident) = do
case positional as of
[] -> fail ("Expected parameter " <> showIdentifier ident)
(x : xs) -> do
addIdentifier ident x
pure $ as {positional = xs}
setParam _ (SinkParam {}) =
fail "setParam encountered SinkParam"
setParam as (DestructuringParam parts) =
case positional as of
[] -> fail ("Expected parameter " <> show parts)
(x : xs) -> do
destructuringBind addIdentifier parts x
pure $ as {positional = xs}
setParam as SkipParam = do
case positional as of
[] -> fail ("missing argument: pattern parameter")
(_ : xs) -> pure $ as {positional = xs}
inBlock FunctionScope $ do
-- We create a closure around the identifiers defined
-- where the function is defined:
oldState <- getState
updateState $ \st -> st {evalIdentifiers = idents}
case mbname of
Nothing -> pure ()
Just name -> addIdentifier name fn
case break isSinkParam params of
(befores, SinkParam mbident : afters) -> do
as' <- foldM setParam arguments befores
as'' <-
foldM
setParam
as' {positional = reverse $ positional as'}
(reverse afters)
let as = as'' {positional = reverse $ positional as''}
case mbident of
Just ident -> addIdentifier ident (VArguments as)
Nothing -> pure ()
_ -> foldM_ setParam arguments params
res <- evalExpr e
setState oldState
pure res
pure fn
-- | Type of TOML configuration file used in 'findPackageEntryPoint' saved as `typst.toml`
data Config = Config {
package :: PackageConfig
} deriving (Show, Generic)
data PackageConfig = PackageConfig {
entrypoint :: String
} deriving (Show, Generic)
-- | Derived generically from record field names
instance Toml.FromValue Config where
fromValue = Toml.genericFromTable
-- | Derived generically from record field names
instance Toml.FromValue PackageConfig where
fromValue = Toml.genericFromTable
findPackageEntryPoint :: Monad m => Text -> MP m FilePath
findPackageEntryPoint modname = do
let (namespace, rest) = break (=='/') (drop 1 $ T.unpack modname)
let (name, rest') = break (==':') $ drop 1 rest
let version = drop 1 rest'
operations <- evalOperations <$> getState
let getEnv var = do
mbv <- lift $ lookupEnvVar operations var
case mbv of
Just v -> pure v
Nothing -> fail (var <> " not defined")
#ifdef __MACOS__
homeDir <- getEnv "HOME"
let localDir = homeDir </> "Library" </> "Application Support" </> "typst"
let cacheDir = homeDir </> "Library" </> "Caches" </> "typst"
#elif __WINDOWS__
appDataDir <- getEnv "APPDATA"
let localDir = appDataDir </> "typst"
localAppDataDir <- getEnv "LOCALAPPDATA"
let cacheDir = localAppDataDir </> "typst"
#else
homeDir <- getEnv "HOME"
dataDir <- lift (lookupEnvVar operations "XDG_DATA_HOME") >>=
maybe (pure (homeDir </> ".local" </> "share")) pure
cacheDir' <- lift (lookupEnvVar operations "XDG_CACHE_HOME") >>=
maybe (pure (homeDir </> ".cache")) pure
let localDir = dataDir </> "typst"
let cacheDir = cacheDir' </> "typst"
#endif
let subpath = "packages" </> namespace </> name </> version
inLocal <- lift $ checkExistence operations (localDir </> subpath </> "typst.toml")
tomlPath <-
if inLocal
then pure (localDir </> subpath </> "typst.toml")
else do
inCache <- lift $ checkExistence operations (cacheDir </> subpath </> "typst.toml")
if inCache
then pure (cacheDir </> subpath </> "typst.toml")
else fail $ "Could not find package in local packages or cache. Looked in\n" ++
(localDir </> subpath) ++ "\n" ++ (cacheDir </> subpath) ++
"\nCompile with typst compile to bring the package into your local cache."
-- TODO? fetch from CDN if not present in cache?
tomlString <- TE.decodeUtf8 <$> lift (loadBytes operations tomlPath)
case Toml.decode tomlString of
Toml.Failure e -> fail (unlines ("Failure loading typst.toml" : e))
Toml.Success _warnings cfg -> -- ignores warnings like unused keys in TOML
pure (replaceFileName tomlPath (entrypoint (package cfg)))
loadModule :: Monad m => Text
-> MP m (Seq Content, (Identifier, M.Map Identifier Val))
loadModule modname = do
(fp, modid, mbPackageRoot, txt) <-
if T.take 1 modname == "@"
then do
fp' <- findPackageEntryPoint modname
operations <- evalOperations <$> getState
txt <- lift $ TE.decodeUtf8 <$> loadBytes operations fp'
pure ( takeFileName fp',
Identifier
(T.pack $ takeWhile (/= ':') . takeBaseName $
T.unpack modname),
Just (takeDirectory fp'),
txt )
else do
let fp = T.unpack modname
txt <- loadFileText fp
pure ( fp,
Identifier (T.pack $ takeBaseName fp),
Nothing,
txt )
fp' <- getPath fp -- get full path for element positions
case parseTypst fp' txt of
Left err -> fail $ show err
Right ms -> do
operations <- evalOperations <$> getState
currentLocalDir <- evalLocalDir <$> getState
currentPackageRoot <- evalPackageRoot <$> getState
let (pkgroot , localdir) =
case mbPackageRoot of
Just r -> (r , takeDirectory fp)
Nothing -> (currentPackageRoot,
currentLocalDir </> takeDirectory fp)
res <-
lift $
runParserT
( inBlock BlockScope $ do -- add new identifiers list
cs <- mconcat <$> many pContent
eof
s <- getState
pure (cs, s)
)
initialEvalState{evalOperations = operations,
evalLocalDir = localdir,
evalPackageRoot = pkgroot }
fp
ms
case res of
Left err' -> fail $ show err'
Right (contents, st) ->
case evalIdentifiers st of
[] -> fail "Empty evalIdentifiers in module!"
((_, m) : _) -> pure (contents, (modid, m))
importModule :: Monad m => M.Map Identifier Val -> MP m ()
importModule m = updateState $ \st ->
st
{ evalIdentifiers =
case evalIdentifiers st of
[] -> [(BlockScope, m)]
((s, i) : is) -> (s, m <> i) : is
}
evalLiteral :: Literal -> Val
evalLiteral lit =
case lit of
String t -> VString t
Boolean b -> VBoolean b
Float x -> VFloat x
Int i -> VInteger i
Numeric x unit ->
case unit of
Fr -> VFraction x
Percent -> VRatio (toRational x / 100)
Deg -> VAngle x
Rad -> VAngle (x * (180 / pi))
Pt -> VLength (LExact x LPt)
Em -> VLength (LExact x LEm)
Mm -> VLength (LExact x LMm)
Cm -> VLength (LExact x LCm)
In -> VLength (LExact x LIn)
None -> VNone
Auto -> VAuto
toArguments :: Monad m => [Arg] -> MP m Arguments
toArguments = foldM addArg (Arguments mempty OM.empty)
where
addArg args (KeyValArg ident e) = do
val <- evalExpr e
pure $ args {named = named args OM.|> (ident, val)}
addArg args (NormalArg e) = do
val <- evalExpr e
pure $ args {positional = positional args ++ [val]}
addArg args (ArrayArg rows) = do
let pRow =
fmap (VArray . V.fromList)
. mapM (fmap VContent . pInnerContents . (: []))
vals <- mapM pRow rows
pure $ args {positional = positional args ++ vals}
addArg args (SpreadArg e) = do
val <- evalExpr e
case val of
VNone -> pure mempty
VArguments args' -> pure $ args <> args'
VDict m ->
pure $
args
<> Arguments {positional = mempty, named = m}
VArray v ->
pure $
args
<> Arguments {positional = V.toList v, named = OM.empty}
_ -> fail $ "spread requires an argument value, got " <> show val
addArg args (BlockArg ms) = do
val <- pInnerContents ms
pure $ args {positional = positional args ++ [VContent val]}
addIdentifier :: Monad m => Identifier -> Val -> MP m ()
addIdentifier ident val = do
identifiers <- evalIdentifiers <$> getState
case identifiers of
[] -> fail "Empty evalIdentifiers"
((s, i) : is) -> updateState $ \st ->
st { evalIdentifiers = (s, M.insert ident val i) : is }
updateIdentifier :: Monad m => Identifier -> Val -> MP m ()
updateIdentifier ident val = do
let go (True, is) (s, m) = pure (True, (s, m) : is)
go (False, is) (s, m) =
case M.lookup ident m of
Nothing
| s == FunctionScope -> fail $ show ident <> " not defined in scope"
| otherwise -> pure (False, (s, m) : is)
Just _ -> pure (True, (s, M.adjust (const val) ident m) : is)
(finished, newmaps) <- getState >>= foldM go (False, []) . evalIdentifiers
if finished
then updateState $ \st -> st {evalIdentifiers = reverse newmaps}
else fail $ show ident <> " not defined"
inBlock :: Monad m => Scope -> MP m a -> MP m a
inBlock scope pa = do
oldStyles <- evalStyles <$> getState
-- add a new identifiers map
updateState $ \st ->
st
{ evalIdentifiers = (scope, mempty) : evalIdentifiers st
}
result <- pa
updateState $ \st ->
st
{ evalIdentifiers = drop 1 (evalIdentifiers st),
evalStyles = oldStyles
}
pure result
updateExpression :: Monad m => Expr -> Val -> MP m ()
updateExpression
(FuncCall (FieldAccess (Ident (Identifier "first")) e') []) val
= updateExpression ( FuncCall
(FieldAccess (Ident (Identifier "at")) e')
[NormalArg (Literal (Int 0))]
) val
updateExpression
(FuncCall (FieldAccess (Ident (Identifier "last")) e') []) val
= updateExpression ( FuncCall
(FieldAccess (Ident (Identifier "at")) e')
[NormalArg (Literal (Int (-1)))]
) val
updateExpression
(FieldAccess (Ident (Identifier fld)) e') val
= updateExpression' True e' (Literal (String fld)) val -- see #26
updateExpression (Ident i) val = updateIdentifier i val
updateExpression
(FuncCall
(FieldAccess (Ident (Identifier "at")) e') [NormalArg arg]) val
= updateExpression' False e' arg val
updateExpression e _ = fail $ "Cannot update expression " <> show e
updateExpression' :: Monad m => Bool -> Expr -> Expr -> Val -> MP m ()
updateExpression' allowNewIndices e arg val = do
container <- evalExpr e
idx <- evalExpr arg
case container of
VArray v ->
case idx of
VInteger i ->
let i' = fromIntegral i
in case v V.!? i' of
Nothing | not allowNewIndices
-> fail $ "Vector does not contain index " <> show i'
_ -> updateExpression e $ VArray $ v V.// [(i', val)]
_ -> fail $ "Cannot index array with " <> show idx
VDict d ->
case idx of
VString fld ->
case OM.lookup (Identifier fld) d of
Nothing | not allowNewIndices
-> fail $ "Dictionary does not contain key " <> show fld
_ -> updateExpression e $
VDict $
OM.alter
( \case
Just _ -> Just val
Nothing -> Just val
)
(Identifier fld)
d
_ -> fail $ "Cannot index dictionary with " <> show idx
_ -> fail $ "Cannot update expression " <> show e
toSelector :: Monad m => Val -> MP m Selector
toSelector (VSelector s) = pure s
toSelector (VFunction (Just name) _ _) = pure $ SelectElement name []
toSelector (VString t) = pure $ SelectString t
toSelector (VRegex re) = pure $ SelectRegex re
toSelector (VLabel t) = pure $ SelectLabel t
toSelector (VSymbol (Symbol t _ _)) = pure $ SelectString t
toSelector v = fail $ "could not convert " <> show v <> " to selector"