typst-0.6.1: src/Typst/Module/Standard.hs
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Typst.Module.Standard
( standardModule,
symModule,
sysModule,
loadFileText,
applyPureFunction
)
where
import Paths_typst (version)
import Data.Version (showVersion)
import Data.Char (ord, chr)
import Control.Applicative ((<|>))
import Control.Monad (mplus, unless)
import Control.Monad.Reader (lift, asks)
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as BL
import qualified Data.Csv as Csv
import qualified Data.Map as M
import qualified Data.Map.Ordered as OM
import Data.Maybe (mapMaybe)
import Data.Ratio ((%))
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 qualified Data.Yaml as Yaml
import Text.Parsec (getPosition, getState, updateState, runParserT)
import Text.Read (readMaybe)
import qualified Text.XML as XML
import qualified Toml
import Typst.Emoji (typstEmojis)
import Typst.Module.Calc (calcModule)
import Typst.Module.Math (mathModule)
import Typst.Regex (makeRE)
import Typst.Symbols (typstSymbols)
import Typst.Types
import Typst.Util
import System.FilePath ((</>))
import Data.List (genericTake)
import Data.Time (UTCTime(..))
import Data.Time.Calendar (fromGregorianValid)
import Data.Time.Clock (secondsToDiffTime)
standardModule :: M.Map Identifier Val
standardModule =
M.fromList $
[ ("math", VModule "math" mathModule),
("sym", VModule "sym" symModule),
("sys", VModule "sys" sysModule),
("emoji", VModule "emoji" emojiModule),
("calc", VModule "calc" calcModule)
]
++ types
++ colors
++ directions
++ alignments
++ textual
++ layout
++ visualize
++ meta
++ foundations
++ construct
++ time
++ dataLoading
sysModule :: M.Map Identifier Val
sysModule =
M.fromList [ ("version", VVersion [0,12,0])
, ("inputs", VDict (OM.fromList
[("typst-hs-version",
VString (T.pack (showVersion version)))]))
]
symModule :: M.Map Identifier Val
symModule = M.map VSymbol $ makeSymbolMap typstSymbols
emojiModule :: M.Map Identifier Val
emojiModule = M.map VSymbol $ makeSymbolMap typstEmojis
textual :: [(Identifier, Val)]
textual =
[ makeElement
Nothing
"text"
[ ("color", One TColor),
("size", One TLength),
("body", One (TContent :|: TString :|: TSymbol))
],
makeElement Nothing "emph" [("body", One TContent)],
makeElement Nothing "linebreak" [],
makeElement Nothing "strong" [("body", One TContent)],
makeElement Nothing "sub" [("body", One TContent)],
makeElement Nothing "super" [("body", One TContent)],
makeElement Nothing "strike" [("body", One TContent)],
makeElement Nothing "smallcaps" [("body", One TContent)],
makeElement Nothing "underline" [("body", One TContent)],
makeElement Nothing "overline" [("body", One TContent)],
makeElement Nothing "highlight" [("body", One TContent)],
makeElement Nothing "raw" [("text", One TString)],
makeElement Nothing "smartquote" [],
makeElement Nothing "lower" [("text", One (TString :|: TContent))],
( "lower",
makeFunction $ do
val <- nthArg 1
case val of
VString t -> pure $ VString $ T.toLower t
VContent cs -> do
pos <- lift getPosition
pure $ VContent . Seq.singleton $ Elt "lower" (Just pos) [("text", VContent cs)]
_ -> fail "argument must be string or content"
),
( "upper",
makeFunction $ do
val <- nthArg 1
case val of
VString t -> pure $ VString $ T.toUpper t
VContent cs -> do
pos <- lift getPosition
pure $ VContent . Seq.singleton $ Elt "upper" (Just pos) [("text", VContent cs)]
_ -> fail "argument must be string or content"
)
]
layout :: [(Identifier, Val)]
layout =
[ makeElement
Nothing
"align"
[ ("alignment", One TAlignment),
("body", One TContent)
],
makeElement Nothing "skew" [("body", One TContent)],
makeElement Nothing "block" [("body", One TContent)],
makeElement Nothing "box" [("body", One TContent)],
makeElement Nothing "colbreak" [],
makeElement Nothing "columns" [("count", One TInteger), ("body", One TContent)],
makeElement Nothing "h" [("amount", One (TLength :|: TRatio :|: TFraction))],
makeElement Nothing "v" [("amount", One (TLength :|: TRatio :|: TFraction))],
makeElement Nothing "hide" [("body", One TContent)],
makeElementWithScope
Nothing
"enum"
[("children", Many TContent)]
[ makeElement
(Just "enum")
"item"
[ ("number", One (TInteger :|: TNone)),
("body", One TContent)
]
],
makeElementWithScope
Nothing
"list"
[("children", Many TContent)]
[makeElement (Just "list") "item" [("body", One TContent)]],
-- for "measure" see below
makeElement Nothing "move" [("body", One TContent)],
-- the fact that pad can take a positional param for a length (= rest) is undocumented!
makeElement Nothing "pad" [("rest", One (TLength :|: TRatio :|: TNone)), ("body", One TContent)],
makeElement Nothing "page" [("body", One TContent)],
makeElement Nothing "pagebreak" [],
makeElement Nothing "par" [("body", One TContent)],
makeElement Nothing "parbreak" [],
makeElement Nothing "place" [("alignment", One (TAlignment :|: TNone)), ("body", One TContent)],
makeElement Nothing "repeat" [("body", One TContent)],
makeElement Nothing "rotate" [("angle", One TAngle), ("body", One TContent)],
-- the fact that scale can take a positional factor is undocumented!
makeElement Nothing "scale" [("factor", One (TRatio :|: TNone)), ("body", One TContent)],
makeElement
Nothing
"stack"
[("children", Many (TLength :|: TRatio :|: TFraction :|: TContent))],
makeElementWithScope Nothing
"table"
[("children", Many TContent)]
[ makeElement (Just "table") "cell" [ ("body", One TContent) ]
, makeElement (Just "table") "hline" []
, makeElement (Just "table") "vline" []
, makeElement (Just "table") "header" [ ("children", Many TContent) ]
, makeElement (Just "table") "footer" [ ("children", Many TContent) ]
],
makeElementWithScope Nothing
"grid"
[("children", Many TContent)]
[ makeElement (Just "grid") "cell" [ ("body", One TContent) ]
, makeElement (Just "grid") "hline" []
, makeElement (Just "grid") "vline" []
, makeElement (Just "grid") "header" [ ("children", Many TContent) ]
, makeElement (Just "grid") "footer" [ ("children", Many TContent) ]
],
makeElementWithScope
Nothing
"terms"
[("children", Many TTermItem)]
[ makeElement
(Just "terms")
"item"
[ ("term", One TContent),
("description", One TContent)
]
],
( "measure",
makeFunction $ do
-- content <- nthArg 1
-- styles <- nthArg 2
pure $
VDict $
OM.fromList
[ ("width", VLength (LExact 1.0 LEm)),
("height", VLength (LExact 1.0 LEm))
]
)
-- these are fake widths so we don't crash...
]
visualize :: [(Identifier, Val)]
visualize =
[ makeElement Nothing "circle" [("body", One (TContent :|: TNone))],
makeElement Nothing "ellipse" [("body", One (TContent :|: TNone))],
makeElement Nothing "image" [("path", One TString)],
makeElement Nothing "line" [],
makeElement Nothing "path" [("vertices", Many TArray)],
makeElement Nothing "polygon" [("vertices", Many TArray)],
makeElement Nothing "rect" [("body", One (TContent :|: TNone))],
makeElement Nothing "square" [("body", One (TContent :|: TNone))]
]
meta :: [(Identifier, Val)]
meta =
[ makeElement Nothing "bibliography" [("path", One (TString :|: TArray))],
makeElement Nothing "cite" [("key", One TLabel)],
makeElement Nothing "document" [],
makeElementWithScope
Nothing
"figure"
[("body", One TContent)]
[makeElement (Just "figure") "caption" [("body", One TContent)]],
makeElement Nothing "heading" [("body", One TContent)],
makeElement Nothing "quote" [("body", One TContent)],
makeElement Nothing "layout" [("func", One TFunction)],
makeElement
Nothing
"link"
[ ("dest", One (TString :|: TLabel :|: TDict :|: TLocation)),
("body", One TContent)
],
makeElement Nothing "locate" [("func", One TFunction)],
makeElement
Nothing
"numbering"
[ ("numbering", One (TString :|: TFunction)),
("numbers", Many TInteger)
],
makeElementWithScope Nothing "outline"
[]
[makeElement (Just "outline") "entry"
[("level", One TInteger),
("element", One TContent),
("body", One TContent),
("fill", One (TContent :|: TNone)),
("page", One TContent)]],
makeElement
Nothing
"query"
[ ("target", One (TLabel :|: TFunction)),
("location", One TLocation)
],
makeElement Nothing "metadata" [ ("value", One TAny) ],
makeElement Nothing "ref" [("target", One TLabel)],
makeElement Nothing "state" [("key", One TString), ("init", One TAny)],
makeElementWithScope
Nothing
"footnote"
[("body", One TContent)]
[makeElement (Just "footnote") "entry" [("note", One TContent)]],
("style", makeFunction $ do
Function f <- nthArg 1
case applyPureFunction (Function f) [VStyles] of
Success x -> pure x
Failure e -> fail e)
]
types :: [(Identifier, Val)]
types =
[ ("array", VType TArray)
, ("bool", VType TBoolean)
, ("content", VType TContent)
, ("int", VType TInteger)
, ("float", VType TFloat)
, ("regex", VType TRegex)
, ("length", VType TLength)
, ("alignment", VType TAlignment)
, ("color", VType TColor)
, ("symbol", VType TSymbol)
, ("string", VType TString)
]
colors :: [(Identifier, Val)]
colors =
[ ("red", VColor $ RGB (0xff % 0xff) (0x41 % 0xff) (0x36 % 0xff) 1),
("blue", VColor $ RGB (0x00 % 0xff) (0x74 % 0xff) (0xd9 % 0xff) 1),
("black", VColor $ RGB (0x00 % 0xff) (0x00 % 0xff) (0x00 % 0xff) 1),
("gray", VColor $ RGB (0xaa % 0xff) (0xaa % 0xff) (0xaa % 0xff) 1),
("silver", VColor $ RGB (0xdd % 0xff) (0xdd % 0xff) (0xdd % 0xff) 1),
("white", VColor $ RGB (0xff % 0xff) (0xff % 0xff) (0xff % 0xff) 1),
("navy", VColor $ RGB (0x00 % 0xff) (0x1f % 0xff) (0x3f % 0xff) 1),
("aqua", VColor $ RGB (0x7f % 0xff) (0xdb % 0xff) (0xff % 0xff) 1),
("teal", VColor $ RGB (0x39 % 0xff) (0xcc % 0xff) (0xcc % 0xff) 1),
("eastern", VColor $ RGB (0x23 % 0xff) (0x9d % 0xff) (0xad % 0xff) 1),
("purple", VColor $ RGB (0xb1 % 0xff) (0x0d % 0xff) (0xc9 % 0xff) 1),
("fuchsia", VColor $ RGB (0xf0 % 0xff) (0x12 % 0xff) (0xbe % 0xff) 1),
("maroon", VColor $ RGB (0x85 % 0xff) (0x14 % 0xff) (0x4b % 0xff) 1),
("yellow", VColor $ RGB (0xff % 0xff) (0xdc % 0xff) (0x00 % 0xff) 1),
("orange", VColor $ RGB (0xff % 0xff) (0x85 % 0xff) (0x1b % 0xff) 1),
("olive", VColor $ RGB (0x3d % 0xff) (0x99 % 0xff) (0x70 % 0xff) 1),
("green", VColor $ RGB (0x2e % 0xff) (0xcc % 0xff) (0x40 % 0xff) 1),
("lime", VColor $ RGB (0x01 % 0xff) (0xff % 0xff) (0x70 % 0xff) 1)
]
directions :: [(Identifier, Val)]
directions =
[ ("ltr", VDirection Ltr),
("rtl", VDirection Rtl),
("ttb", VDirection Ttb),
("btt", VDirection Btt)
]
alignments :: [(Identifier, Val)]
alignments =
[ ("start", VAlignment (Just HorizStart) Nothing),
("end", VAlignment (Just HorizEnd) Nothing),
("left", VAlignment (Just HorizLeft) Nothing),
("center", VAlignment (Just HorizCenter) Nothing),
("right", VAlignment (Just HorizRight) Nothing),
("top", VAlignment Nothing (Just VertTop)),
("horizon", VAlignment Nothing (Just VertHorizon)),
("bottom", VAlignment Nothing (Just VertBottom))
]
foundations :: [(Identifier, Val)]
foundations =
[ ( "assert",
makeFunctionWithScope
( do
(cond :: Bool) <- nthArg 1
unless cond $ do
(msg :: String) <- namedArg "message" "Assertion failed"
fail msg
pure VNone
)
[ ( "eq",
makeFunction $ do
(v1 :: Val) <- nthArg 1
(v2 :: Val) <- nthArg 2
unless (comp v1 v2 == Just EQ) $ fail "Assertion failed"
pure VNone
),
( "ne",
makeFunction $ do
(v1 :: Val) <- nthArg 1
(v2 :: Val) <- nthArg 2
unless (comp v1 v2 /= Just EQ) $ fail "Assertion failed"
pure VNone
)
]
),
("panic", makeFunction $ allArgs >>= fail . T.unpack .
(("panicked with: " <>) . T.unlines . map repr)),
("repr", makeFunction $ nthArg 1 >>= pure . VString . repr),
( "type",
makeFunction $ do
(x :: Val) <- nthArg 1
pure $ VType $ valType x
)
]
construct :: [(Identifier, Val)]
construct =
[ ( "cmyk",
makeFunction $
VColor <$> (CMYK <$> nthArg 1 <*> nthArg 2 <*> nthArg 3 <*> nthArg 4)
),
("float", makeFunction $ VFloat <$> nthArg 1),
("int", makeFunction $ VInteger <$> nthArg 1),
("label", makeFunction $ VLabel <$> nthArg 1),
( "counter",
makeFunction $ do
(counter :: Counter) <- nthArg 1
let initializeIfMissing Nothing = Just 0
initializeIfMissing (Just x) = Just x
lift $ updateState $ \st ->
st {evalCounters = M.alter initializeIfMissing counter $ evalCounters st}
pure $ VCounter counter
),
("luma", makeFunction $ VColor <$> (Luma <$> nthArg 1)),
( "range",
makeFunction $ do
first <- nthArg 1
mbsecond <- nthArg 2
step <- namedArg "step" 1
pure $
VArray $
V.fromList $
map VInteger $
case (first, mbsecond) of
(end, Nothing) -> enumFromThenTo 0 step (end - 1)
(start, Just end) ->
enumFromThenTo
start
(start + step)
( if start < end
then end - 1
else end + 1
)
),
("regex", makeFunction $ VRegex <$> (nthArg 1 >>= makeRE)),
( "rgb",
makeFunction $
VColor
<$> ( ( RGB
<$> (nthArg 1 >>= toRatio)
<*> (nthArg 2 >>= toRatio)
<*> (nthArg 3 >>= toRatio)
<*> ((nthArg 4 >>= toRatio) `mplus` pure 1.0)
)
<|> (nthArg 1 >>= hexToRGB)
)
),
( "str",
makeFunctionWithScope
(do
val <- nthArg 1
base <- namedArg "base" (10 :: Integer)
let digitVector :: V.Vector Char
digitVector = V.fromList $ ['0'..'9'] ++ ['A'..'Z']
let renderDigit n = digitVector V.!? (fromIntegral n)
VString <$>
case val of
VInteger n | base /= 10
-> case mDigits base n of
Nothing -> fail "Could not convert number to base"
Just ds -> maybe
(fail "Could not convert number to base")
(pure . T.pack)
(mapM renderDigit ds)
_ -> fromVal val `mplus` pure (repr val))
[ ( "to-unicode",
makeFunction $ do
(val :: Text) <- nthArg 1
case T.uncons val of
Just (c, t) | T.null t ->
pure $ VInteger $ fromIntegral $ ord c
_ -> fail "to-unicode expects a single character" )
, ( "from-unicode",
makeFunction $ do
(val :: Int) <- nthArg 1
pure $ VString $ T.pack [chr val] )
]
),
( "version",
makeFunction $ do
xs <- asks positional >>= mapM fromVal
pure $ VVersion xs
),
( "symbol",
makeFunction $ do
(t :: Text) <- nthArg 1
vs <- drop 1 <$> allArgs
variants <-
mapM
( \case
VArray [VString k, VString v] ->
pure (Set.fromList (T.split (== '.') k), v)
_ -> fail "wrong type in symbol arguments"
)
vs
pure $ VSymbol $ Symbol t False variants
),
( "lorem",
makeFunction $ do
(num :: Int) <- nthArg 1
pure $ VString $ T.unwords $ take num loremWords
)
]
loremWords :: [Text]
loremWords =
cycle $
T.words $
"Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do\
\ eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut\
\ enim ad minim veniam, quis nostrud exercitation ullamco laboris\
\ nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in\
\ reprehenderit in voluptate velit esse cillum dolore eu fugiat\
\ nulla pariatur. Excepteur sint occaecat cupidatat non proident,\
\ sunt in culpa qui officia deserunt mollit anim id est laborum."
toRatio :: MonadFail m => Val -> m Rational
toRatio (VRatio r) = pure r
toRatio (VInteger i) = pure $ i % 255
toRatio _ = fail "cannot convert to rational"
hexToRGB :: MonadFail m => Val -> m Color
hexToRGB (VString s) = do
let s' = T.dropWhile (== '#') s
parts <-
map (fmap (% 255) . readMaybe . T.unpack . ("0x" <>))
<$> case T.length s' of
3 -> pure $ T.chunksOf 1 s'
4 -> pure $ T.chunksOf 1 s'
6 -> pure $ T.chunksOf 2 s'
8 -> pure $ T.chunksOf 2 s'
_ -> fail "hex string must be 3, 4, 6, or 8 digits"
case parts of
[Just r, Just g, Just b] -> pure $ RGB r g b 1.0
[Just r, Just g, Just b, Just o] -> pure $ RGB r g b o
_ -> fail "could not read string as hex color"
hexToRGB _ = fail "expected string"
loadFileLazyBytes :: Monad m => FilePath -> MP m BL.ByteString
loadFileLazyBytes fp = do
operations <- evalOperations <$> getState
root <- evalPackageRoot <$> getState
lift $ BL.fromStrict <$> loadBytes operations (root </> fp)
loadFileText :: Monad m => FilePath -> MP m T.Text
loadFileText fp = do
operations <- evalOperations <$> getState
root <- evalPackageRoot <$> getState
lift $ TE.decodeUtf8 <$> loadBytes operations (root </> fp)
getUTCTime :: Monad m => MP m UTCTime
getUTCTime = (currentUTCTime . evalOperations <$> getState) >>= lift
time :: [(Identifier, Val)]
time =
[ ( "datetime", makeFunctionWithScope
(do
mbyear <- namedArg "year" Nothing
mbmonth <- namedArg "month" Nothing
mbday <- namedArg "day" Nothing
let mbdate = case (mbyear, mbmonth, mbday) of
(Just yr, Just mo, Just da) -> fromGregorianValid yr mo da
_ -> Nothing
mbhour <- namedArg "hour" Nothing
mbminute <- namedArg "minute" Nothing
mbsecond <- namedArg "second" Nothing
let mbtime = case (mbhour, mbminute, mbsecond) of
(Just hr, Just mi, Just se) ->
Just $ secondsToDiffTime $ (hr * 60 * 60) + (mi * 60) + se
_ -> Nothing
pure $ VDateTime mbdate mbtime)
[ ("today", makeFunction $ do
utcTime <- lift getUTCTime
pure $ VDateTime (Just (utctDay utcTime)) (Just (utctDayTime utcTime)) ) ]
)
]
dataLoading :: [(Identifier, Val)]
dataLoading =
[ ( "csv",
makeFunction $ do
fp <- nthArg 1
bs <- lift $ loadFileLazyBytes fp
case Csv.decode Csv.NoHeader bs of
Left e -> fail e
Right (v :: V.Vector (V.Vector String)) ->
pure $ VArray $ V.map (VArray . V.map (VString . T.pack)) v
),
( "json",
makeFunction $ do
fp <- nthArg 1
bs <- lift $ loadFileLazyBytes fp
case Aeson.eitherDecode bs of
Left e -> fail e
Right (v :: Val) -> pure v
),
( "yaml",
makeFunction $ do
fp <- nthArg 1
bs <- lift $ loadFileLazyBytes fp
case Yaml.decodeEither' (BL.toStrict bs) of
Left e -> fail $ show e
Right (v :: Val) -> pure v
),
( "read",
makeFunction $ do
fp <- nthArg 1
t <- lift $ loadFileText fp
pure $ VString t
),
( "toml",
makeFunction $ do
fp <- nthArg 1
t <- lift $ loadFileText fp
case Toml.decode t of
Toml.Failure e -> fail (unlines ("toml errors:" : e))
Toml.Success _ v -> pure v
),
( "xml",
makeFunction $ do
fp <- nthArg 1
bs <- lift $ loadFileLazyBytes fp
case XML.parseLBS XML.def bs of
Left e -> fail $ show e
Right doc ->
pure $
VArray $
V.fromList $
mapMaybe
nodeToVal
[XML.NodeElement (XML.documentRoot doc)]
where
showname n = XML.nameLocalName n
nodeToVal (XML.NodeElement elt) = Just $ eltToDict elt
nodeToVal (XML.NodeContent t) = Just $ VString t
nodeToVal _ = Nothing
eltToDict elt =
VDict $
OM.fromList
[ ("tag", VString $ showname (XML.elementName elt)),
( "attrs",
VDict $
OM.fromList $
map
(\(k, v) -> (Identifier (showname k), VString v))
(M.toList $ XML.elementAttributes elt)
),
( "children",
VArray $
V.fromList $
mapMaybe nodeToVal (XML.elementNodes elt)
)
]
)
]
applyPureFunction :: Function -> [Val] -> Attempt Val
applyPureFunction (Function f) vals =
let args = Arguments vals OM.empty
in case runParserT (f args) initialEvalState "" [] of
Failure s -> Failure s
Success (Left s) -> Failure $ show s
Success (Right v) -> Success v
initialEvalState :: MonadFail m => EvalState m
initialEvalState =
emptyEvalState { evalIdentifiers = [(BlockScope, mempty)]
, evalMathIdentifiers = [(BlockScope, mathModule <> symModule)]
, evalStandardIdentifiers = [(BlockScope, standardModule)]
}
-- mDigitsRev, mDigits from the unmaintained digits package
-- https://hackage.haskell.org/package/digits-0.3.1
-- (c) 2009-2016 Henry Bucklow, Charlie Harvey -- BSD-3-Clause license.
mDigitsRev :: Integral n
=> n -- ^ The base to use.
-> n -- ^ The number to convert to digit form.
-> Maybe [n] -- ^ Nothing or Just the digits of the number in list form, in reverse.
mDigitsRev base i = if base < 1
then Nothing -- We do not support zero or negative bases
else Just $ dr base i
where
dr _ 0 = []
dr b x = case base of
1 -> genericTake x $ repeat 1
_ -> let (rest, lastDigit) = quotRem x b
in lastDigit : dr b rest
-- | Returns the digits of a positive integer as a Maybe list.
-- or Nothing if a zero or negative base is given
mDigits :: Integral n
=> n -- ^ The base to use.
-> n -- ^ The number to convert to digit form.
-> Maybe [n] -- ^ Nothing or Just the digits of the number in list form
mDigits base i = reverse <$> mDigitsRev base i