{- |
Module      : Text.Pandoc.Class.Sandbox
Copyright   : Copyright (C) 2021-2024 John MacFarlane
License     : GNU GPL, version 2 or above

Maintainer  : John MacFarlane (<jgm@berkeley.edu>)
Stability   : alpha
Portability : portable

This module provides a way to run PandocMonad actions in a sandbox
(pure context, with no IO allowed and access only to designated files).
-}

module Text.Pandoc.Class.Sandbox
  ( sandbox )
where

import Control.Monad (foldM)
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Text.Pandoc.Class.PandocMonad
import Text.Pandoc.Class.PandocPure
import Text.Pandoc.Class.CommonState (CommonState(..))
import Text.Pandoc.Logging (messageVerbosity)

-- | Lift a PandocPure action into any instance of PandocMonad.
-- The main computation is done purely, but CommonState is preserved
-- continuously, and warnings are emitted after the action completes.
-- The parameter is a list of FilePaths which will be added to the
-- ersatz file system and be available for reading.
sandbox :: (PandocMonad m, MonadIO m) => [FilePath] -> PandocPure a -> m a
sandbox :: forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
[FilePath] -> PandocPure a -> m a
sandbox [FilePath]
files PandocPure a
action = do
  oldState <- m CommonState
forall (m :: * -> *). PandocMonad m => m CommonState
getCommonState
  tree <- liftIO $ foldM addToFileTree mempty files
  case runPure (do putCommonState oldState
                   modifyPureState $ \PureState
ps -> PureState
ps{ stFiles = tree }
                   result <- action
                   st <- getCommonState
                   return (st, result)) of
          Left PandocError
e -> PandocError -> m a
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PandocError
e
          Right (CommonState
st, a
result) -> do
            CommonState -> m ()
forall (m :: * -> *). PandocMonad m => CommonState -> m ()
putCommonState CommonState
st
            let verbosity :: Verbosity
verbosity = CommonState -> Verbosity
stVerbosity CommonState
st
            -- emit warnings, since these are not printed in runPure
            let newMessages :: [LogMessage]
newMessages = [LogMessage] -> [LogMessage]
forall a. [a] -> [a]
reverse ([LogMessage] -> [LogMessage]) -> [LogMessage] -> [LogMessage]
forall a b. (a -> b) -> a -> b
$ Int -> [LogMessage] -> [LogMessage]
forall a. Int -> [a] -> [a]
take
                  ([LogMessage] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (CommonState -> [LogMessage]
stLog CommonState
st) Int -> Int -> Int
forall a. Num a => a -> a -> a
- [LogMessage] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (CommonState -> [LogMessage]
stLog CommonState
oldState)) (CommonState -> [LogMessage]
stLog CommonState
st)
            (LogMessage -> m ()) -> [LogMessage] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
logOutput
              ((LogMessage -> Bool) -> [LogMessage] -> [LogMessage]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
<= Verbosity
verbosity) (Verbosity -> Bool)
-> (LogMessage -> Verbosity) -> LogMessage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> Verbosity
messageVerbosity) [LogMessage]
newMessages)
            a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result