{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {- | Module : Text.Pandoc.Lua.Util Copyright : © 2012–2019 John MacFarlane, © 2017-2019 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> Stability : alpha Lua utility functions. -} module Text.Pandoc.Lua.Util ( getTag , rawField , addField , addFunction , addValue , pushViaConstructor , loadScriptFromDataDir , defineHowTo , throwTopMessageAsError' , callWithTraceback , dofileWithTraceback ) where import Prelude import Control.Monad (unless, when) import Foreign.Lua ( Lua, NumArgs, NumResults, Peekable, Pushable, StackIndex , Status, ToHaskellFunction ) import Text.Pandoc.Class (readDataFile, runIOorExplode, setUserDataDir) import qualified Foreign.Lua as Lua import qualified Text.Pandoc.UTF8 as UTF8 -- | Get value behind key from table at given index. rawField :: Peekable a => StackIndex -> String -> Lua a rawField idx key = do absidx <- Lua.absindex idx Lua.push key Lua.rawget absidx Lua.popValue -- | Add a value to the table at the top of the stack at a string-index. addField :: Pushable a => String -> a -> Lua () addField = addValue -- | Add a key-value pair to the table at the top of the stack. addValue :: (Pushable a, Pushable b) => a -> b -> Lua () addValue key value = do Lua.push key Lua.push value Lua.rawset (Lua.nthFromTop 3) -- | Add a function to the table at the top of the stack, using the given name. addFunction :: ToHaskellFunction a => String -> a -> Lua () addFunction name fn = do Lua.push name Lua.pushHaskellFunction fn Lua.rawset (-3) -- | Helper class for pushing a single value to the stack via a lua function. -- See @pushViaCall@. class PushViaCall a where pushViaCall' :: String -> Lua () -> NumArgs -> a instance PushViaCall (Lua ()) where pushViaCall' fn pushArgs num = do Lua.push fn Lua.rawget Lua.registryindex pushArgs Lua.call num 1 instance (Pushable a, PushViaCall b) => PushViaCall (a -> b) where pushViaCall' fn pushArgs num x = pushViaCall' fn (pushArgs *> Lua.push x) (num + 1) -- | Push an value to the stack via a lua function. The lua function is called -- with all arguments that are passed to this function and is expected to return -- a single value. pushViaCall :: PushViaCall a => String -> a pushViaCall fn = pushViaCall' fn (return ()) 0 -- | Call a pandoc element constructor within lua, passing all given arguments. pushViaConstructor :: PushViaCall a => String -> a pushViaConstructor pandocFn = pushViaCall ("pandoc." ++ pandocFn) -- | Load a file from pandoc's data directory. loadScriptFromDataDir :: Maybe FilePath -> FilePath -> Lua () loadScriptFromDataDir datadir scriptFile = do script <- Lua.liftIO . runIOorExplode $ setUserDataDir datadir >> readDataFile scriptFile status <- Lua.dostring script when (status /= Lua.OK) $ throwTopMessageAsError' (("Couldn't load '" ++ scriptFile ++ "'.\n") ++) -- | Get the tag of a value. This is an optimized and specialized version of -- @Lua.getfield idx "tag"@. It only checks for the field on the table at index -- @idx@ and on its metatable, also ignoring any @__index@ value on the -- metatable. getTag :: StackIndex -> Lua String getTag idx = do -- push metatable or just the table Lua.getmetatable idx >>= \hasMT -> unless hasMT (Lua.pushvalue idx) Lua.push "tag" Lua.rawget (Lua.nthFromTop 2) Lua.tostring Lua.stackTop <* Lua.pop 2 >>= \case Nothing -> Lua.throwException "untagged value" Just x -> return (UTF8.toString x) -- | Modify the message at the top of the stack before throwing it as an -- Exception. throwTopMessageAsError' :: (String -> String) -> Lua a throwTopMessageAsError' modifier = do msg <- Lua.tostring' Lua.stackTop Lua.pop 2 -- remove error and error string pushed by tostring' Lua.throwException (modifier (UTF8.toString msg)) -- | Mark the context of a Lua computation for better error reporting. defineHowTo :: String -> Lua a -> Lua a defineHowTo ctx = Lua.withExceptionMessage (("Could not " <> ctx <> ": ") <>) -- | Like @'Lua.pcall'@, but uses a predefined error handler which adds a -- traceback on error. pcallWithTraceback :: NumArgs -> NumResults -> Lua Status pcallWithTraceback nargs nresults = do let traceback' :: Lua NumResults traceback' = do l <- Lua.state msg <- Lua.tostring' (Lua.nthFromBottom 1) Lua.traceback l (Just (UTF8.toString msg)) 2 return 1 tracebackIdx <- Lua.absindex (Lua.nthFromTop (Lua.fromNumArgs nargs + 1)) Lua.pushHaskellFunction traceback' Lua.insert tracebackIdx result <- Lua.pcall nargs nresults (Just tracebackIdx) Lua.remove tracebackIdx return result -- | Like @'Lua.call'@, but adds a traceback to the error message (if any). callWithTraceback :: NumArgs -> NumResults -> Lua () callWithTraceback nargs nresults = do result <- pcallWithTraceback nargs nresults when (result /= Lua.OK) Lua.throwTopMessage -- | Run the given string as a Lua program, while also adding a traceback to the -- error message if an error occurs. dofileWithTraceback :: FilePath -> Lua Status dofileWithTraceback fp = do loadRes <- Lua.loadfile fp case loadRes of Lua.OK -> pcallWithTraceback 0 Lua.multret _ -> return loadRes