generated from srid/ema-template
-
Notifications
You must be signed in to change notification settings - Fork 67
/
Filter.hs
51 lines (47 loc) · 2.06 KB
/
Filter.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
module Emanote.Model.Note.Filter (applyPandocFilters) where
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Writer.Strict (MonadWriter (tell))
import Data.Default (def)
import Emanote.Prelude (logE, logW)
import Relude
import System.Directory (doesFileExist)
import System.FilePath (takeExtension)
import Text.Pandoc (runIO)
import Text.Pandoc.Definition (Pandoc (..))
import Text.Pandoc.Filter qualified as PF
import Text.Pandoc.Scripting (ScriptingEngine)
import UnliftIO.Exception (handle)
applyPandocFilters :: (MonadIO m, MonadLogger m, MonadWriter [Text] m) => ScriptingEngine -> [FilePath] -> Pandoc -> m Pandoc
applyPandocFilters scriptingEngine paths doc = do
res <- traverse mkLuaFilter paths
forM_ (lefts res) $ \err ->
tell [err]
case rights res of
[] ->
pure doc
filters ->
applyPandocLuaFilters scriptingEngine filters doc >>= \case
Left err -> tell [err] >> pure doc
Right x -> pure x
mkLuaFilter :: (MonadIO m) => FilePath -> m (Either Text PF.Filter)
mkLuaFilter relPath = do
if takeExtension relPath == ".lua"
then do
liftIO (doesFileExist relPath) >>= \case
True -> pure $ Right $ PF.LuaFilter relPath
False -> pure $ Left $ toText $ "Lua filter missing: " <> relPath
else pure $ Left $ "Unsupported filter: " <> toText relPath
applyPandocLuaFilters :: (MonadIO m, MonadLogger m) => ScriptingEngine -> [PF.Filter] -> Pandoc -> m (Either Text Pandoc)
applyPandocLuaFilters scriptingEngine filters x = do
logW $ "[Experimental feature] Applying pandoc filters: " <> show filters
-- TODO: Can we constrain this to run Lua code purely (embedded) without using IO?
liftIO (runIOCatchingErrors $ PF.applyFilters scriptingEngine def filters ["markdown"] x) >>= \case
Left err -> do
logE $ "Error applying pandoc filters: " <> show err
pure $ Left (show err)
Right x' -> pure $ Right x'
where
-- `runIO` can throw `PandocError`. Fix this nonsense behaviour, by catching
-- it and returning a `Left`.
runIOCatchingErrors =
handle (pure . Left) . runIO