{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Filter
( Filter (..)
, Environment (..)
, applyFilters
) where
import System.CPUTime (getCPUTime)
import Data.Aeson
import GHC.Generics (Generic)
import Text.Pandoc.Class (report, getVerbosity, PandocMonad)
import Text.Pandoc.Definition (Pandoc)
import Text.Pandoc.Filter.Environment (Environment (..))
import Text.Pandoc.Logging
import Text.Pandoc.Citeproc (processCitations)
import qualified Text.Pandoc.Filter.JSON as JSONFilter
import qualified Text.Pandoc.Filter.Lua as LuaFilter
import qualified Text.Pandoc.Filter.Path as Path
import qualified Data.Text as T
import System.FilePath (takeExtension)
import Control.Applicative ((<|>))
import Control.Monad.Trans (MonadIO (liftIO))
import Control.Monad (foldM, when)
data Filter = LuaFilter FilePath
| JSONFilter FilePath
| CiteprocFilter
deriving (Int -> Filter -> ShowS
[Filter] -> ShowS
Filter -> String
(Int -> Filter -> ShowS)
-> (Filter -> String) -> ([Filter] -> ShowS) -> Show Filter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Filter] -> ShowS
$cshowList :: [Filter] -> ShowS
show :: Filter -> String
$cshow :: Filter -> String
showsPrec :: Int -> Filter -> ShowS
$cshowsPrec :: Int -> Filter -> ShowS
Show, (forall x. Filter -> Rep Filter x)
-> (forall x. Rep Filter x -> Filter) -> Generic Filter
forall x. Rep Filter x -> Filter
forall x. Filter -> Rep Filter x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Filter x -> Filter
$cfrom :: forall x. Filter -> Rep Filter x
Generic)
instance FromJSON Filter where
parseJSON :: Value -> Parser Filter
parseJSON node :: Value
node =
(String -> (Object -> Parser Filter) -> Value -> Parser Filter
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "Filter" ((Object -> Parser Filter) -> Value -> Parser Filter)
-> (Object -> Parser Filter) -> Value -> Parser Filter
forall a b. (a -> b) -> a -> b
$ \m :: Object
m -> do
Text
ty <- Object
m Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: "type"
Maybe Text
fp <- Object
m Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? "path"
let missingPath :: Parser a
missingPath = String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ "Expected 'path' for filter of type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
ty
let filterWithPath :: (String -> a) -> Maybe Text -> Parser a
filterWithPath constr :: String -> a
constr = Parser a -> (Text -> Parser a) -> Maybe Text -> Parser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parser a
forall a. Parser a
missingPath (a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parser a) -> (Text -> a) -> Text -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
constr (String -> a) -> (Text -> String) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)
case Text
ty of
"citeproc" -> Filter -> Parser Filter
forall (m :: * -> *) a. Monad m => a -> m a
return Filter
CiteprocFilter
"lua" -> (String -> Filter) -> Maybe Text -> Parser Filter
forall a. (String -> a) -> Maybe Text -> Parser a
filterWithPath String -> Filter
LuaFilter Maybe Text
fp
"json" -> (String -> Filter) -> Maybe Text -> Parser Filter
forall a. (String -> a) -> Maybe Text -> Parser a
filterWithPath String -> Filter
JSONFilter Maybe Text
fp
_ -> String -> Parser Filter
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Filter) -> String -> Parser Filter
forall a b. (a -> b) -> a -> b
$ "Unknown filter type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show (Text
ty :: T.Text)) Value
node
Parser Filter -> Parser Filter -> Parser Filter
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(String -> (Text -> Parser Filter) -> Value -> Parser Filter
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText "Filter" ((Text -> Parser Filter) -> Value -> Parser Filter)
-> (Text -> Parser Filter) -> Value -> Parser Filter
forall a b. (a -> b) -> a -> b
$ \t :: Text
t -> do
let fp :: String
fp = Text -> String
T.unpack Text
t
if String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "citeproc"
then Filter -> Parser Filter
forall (m :: * -> *) a. Monad m => a -> m a
return Filter
CiteprocFilter
else Filter -> Parser Filter
forall (m :: * -> *) a. Monad m => a -> m a
return (Filter -> Parser Filter) -> Filter -> Parser Filter
forall a b. (a -> b) -> a -> b
$
case ShowS
takeExtension String
fp of
".lua" -> String -> Filter
LuaFilter String
fp
_ -> String -> Filter
JSONFilter String
fp) Value
node
instance ToJSON Filter where
toJSON :: Filter -> Value
toJSON CiteprocFilter = [Pair] -> Value
object [ "type" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String "citeproc" ]
toJSON (LuaFilter fp :: String
fp) = [Pair] -> Value
object [ "type" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String "lua",
"path" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
T.pack String
fp) ]
toJSON (JSONFilter fp :: String
fp) = [Pair] -> Value
object [ "type" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String "json",
"path" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
T.pack String
fp) ]
applyFilters :: (PandocMonad m, MonadIO m)
=> Environment
-> [Filter]
-> [String]
-> Pandoc
-> m Pandoc
applyFilters :: Environment -> [Filter] -> [String] -> Pandoc -> m Pandoc
applyFilters fenv :: Environment
fenv filters :: [Filter]
filters args :: [String]
args d :: Pandoc
d = do
[Filter]
expandedFilters <- (Filter -> m Filter) -> [Filter] -> m [Filter]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Filter -> m Filter
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
Filter -> m Filter
expandFilterPath [Filter]
filters
(Pandoc -> Filter -> m Pandoc) -> Pandoc -> [Filter] -> m Pandoc
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Pandoc -> Filter -> m Pandoc
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
Pandoc -> Filter -> m Pandoc
applyFilter Pandoc
d [Filter]
expandedFilters
where
applyFilter :: Pandoc -> Filter -> m Pandoc
applyFilter doc :: Pandoc
doc (JSONFilter f :: String
f) =
String -> m Pandoc -> m Pandoc
forall (m :: * -> *) b.
(PandocMonad m, MonadIO m) =>
String -> m b -> m b
withMessages String
f (m Pandoc -> m Pandoc) -> m Pandoc -> m Pandoc
forall a b. (a -> b) -> a -> b
$ Environment -> [String] -> String -> Pandoc -> m Pandoc
forall (m :: * -> *).
MonadIO m =>
Environment -> [String] -> String -> Pandoc -> m Pandoc
JSONFilter.apply Environment
fenv [String]
args String
f Pandoc
doc
applyFilter doc :: Pandoc
doc (LuaFilter f :: String
f) =
String -> m Pandoc -> m Pandoc
forall (m :: * -> *) b.
(PandocMonad m, MonadIO m) =>
String -> m b -> m b
withMessages String
f (m Pandoc -> m Pandoc) -> m Pandoc -> m Pandoc
forall a b. (a -> b) -> a -> b
$ Environment -> [String] -> String -> Pandoc -> m Pandoc
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
Environment -> [String] -> String -> Pandoc -> m Pandoc
LuaFilter.apply Environment
fenv [String]
args String
f Pandoc
doc
applyFilter doc :: Pandoc
doc CiteprocFilter =
Pandoc -> m Pandoc
forall (m :: * -> *). PandocMonad m => Pandoc -> m Pandoc
processCitations Pandoc
doc
withMessages :: String -> m b -> m b
withMessages f :: String
f action :: m b
action = do
Verbosity
verbosity <- m Verbosity
forall (m :: * -> *). PandocMonad m => m Verbosity
getVerbosity
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
INFO) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ String -> LogMessage
RunningFilter String
f
Integer
starttime <- IO Integer -> m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCPUTime
b
res <- m b
action
Integer
endtime <- IO Integer -> m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCPUTime
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
INFO) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Integer -> LogMessage
FilterCompleted String
f (Integer -> LogMessage) -> Integer -> LogMessage
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Integral a => a -> a
toMilliseconds (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
endtime Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
starttime
b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
res
toMilliseconds :: a -> a
toMilliseconds picoseconds :: a
picoseconds = a
picoseconds a -> a -> a
forall a. Integral a => a -> a -> a
`div` 1000000000
expandFilterPath :: (PandocMonad m, MonadIO m) => Filter -> m Filter
expandFilterPath :: Filter -> m Filter
expandFilterPath (LuaFilter fp :: String
fp) = String -> Filter
LuaFilter (String -> Filter) -> m String -> m Filter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m String
forall (m :: * -> *). PandocMonad m => String -> m String
Path.expandFilterPath String
fp
expandFilterPath (JSONFilter fp :: String
fp) = String -> Filter
JSONFilter (String -> Filter) -> m String -> m Filter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m String
forall (m :: * -> *). PandocMonad m => String -> m String
Path.expandFilterPath String
fp
expandFilterPath CiteprocFilter = Filter -> m Filter
forall (m :: * -> *) a. Monad m => a -> m a
return Filter
CiteprocFilter