{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{- |
Copyright  : © 2021-2022 Albert Krewinkel
License    : MIT
Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>

Marshaling/unmarshaling functions Lua filters, i.e., tables containing
functions to be called on specific elements.
-}
module Text.Pandoc.Lua.Marshal.Filter
  ( -- * Filters
    Filter (..)
  , WalkingOrder (..)
  , peekFilter
  , lookup
  , member
    -- * Individual filter functions
  , FilterFunction (..)
  , peekFilterFunction
  , pushFilterFunction
  , getFunctionFor
    -- * Names in filter functions
  , baseFunctionName
  , listFunctionName
  , valueFunctionNames
  ) where

import Prelude hiding (lookup)
import Control.Applicative ((<|>), optional)
import Control.Monad ((<$!>), void)
import Data.Data
  ( Data, dataTypeConstrs, dataTypeName, dataTypeOf
  , showConstr, toConstr, tyconUQname )
import Data.Foldable (foldrM)
import Data.Map (Map)
import Data.Proxy (Proxy (Proxy))
import Data.String (IsString (fromString))
import HsLua
import Text.Pandoc.Definition (Pandoc, Meta, Block, Inline)
import qualified Data.Map.Strict as Map

-- | Filter function stored in the registry
newtype FilterFunction = FilterFunction Reference

-- | Pushes a filter function to the stack.
--
-- Filter functions are stored in the registry and retrieved from there.
pushFilterFunction :: LuaError e => FilterFunction -> LuaE e ()
pushFilterFunction :: FilterFunction -> LuaE e ()
pushFilterFunction (FilterFunction Reference
fnRef) =
  LuaE e Type -> LuaE e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LuaE e Type -> LuaE e ()) -> LuaE e Type -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ StackIndex -> Reference -> LuaE e Type
forall e. LuaError e => StackIndex -> Reference -> LuaE e Type
getref StackIndex
registryindex Reference
fnRef

-- | Retrieves a filter function from the stack.
--
-- The value at the given index must be a function. It is stored in the
-- Lua registry.
peekFilterFunction :: Peeker e FilterFunction
peekFilterFunction :: Peeker e FilterFunction
peekFilterFunction = Name
-> (StackIndex -> LuaE e Bool)
-> Peeker e FilterFunction
-> Peeker e FilterFunction
forall e a.
Name -> (StackIndex -> LuaE e Bool) -> Peeker e a -> Peeker e a
typeChecked Name
"function" StackIndex -> LuaE e Bool
forall e. StackIndex -> LuaE e Bool
isfunction (Peeker e FilterFunction -> Peeker e FilterFunction)
-> Peeker e FilterFunction -> Peeker e FilterFunction
forall a b. (a -> b) -> a -> b
$ \StackIndex
idx -> LuaE e FilterFunction -> Peek e FilterFunction
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e FilterFunction -> Peek e FilterFunction)
-> LuaE e FilterFunction -> Peek e FilterFunction
forall a b. (a -> b) -> a -> b
$ do
  StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
pushvalue StackIndex
idx
  Reference -> FilterFunction
FilterFunction (Reference -> FilterFunction)
-> LuaE e Reference -> LuaE e FilterFunction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StackIndex -> LuaE e Reference
forall e. StackIndex -> LuaE e Reference
ref StackIndex
registryindex


-- | Collection of filter functions (at most one function per element
-- constructor)
data Filter = Filter
  { Filter -> WalkingOrder
filterWalkingOrder :: WalkingOrder
  , Filter -> Map Name FilterFunction
filterMap :: Map Name FilterFunction
  }

-- | Description of how an AST should be traversed.
data WalkingOrder
  = WalkForEachType  -- ^ Process each type separately, traversing the
                     -- tree bottom-up (leaves to root) for each type.
  | WalkTopdown      -- ^ Traverse the tree top-down, from root to
                     -- leaves and depth first, in a single traversal.

-- | Retrieves a default `Filter` object from the stack, suitable for
-- filtering a full document.
peekFilter :: LuaError e => Peeker e Filter
peekFilter :: Peeker e Filter
peekFilter = [Name] -> Peeker e Filter
forall e. LuaError e => [Name] -> Peeker e Filter
peekFilter' ([Name] -> Peeker e Filter) -> [Name] -> Peeker e Filter
forall a b. (a -> b) -> a -> b
$
    Proxy Pandoc -> Name
forall a. Data a => Proxy a -> Name
baseFunctionName (Proxy Pandoc
forall k (t :: k). Proxy t
Proxy @Pandoc)
  Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Proxy Meta -> Name
forall a. Data a => Proxy a -> Name
baseFunctionName (Proxy Meta
forall k (t :: k). Proxy t
Proxy @Meta)
  Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Proxy Block -> Name
forall a. Data a => Proxy a -> Name
baseFunctionName (Proxy Block
forall k (t :: k). Proxy t
Proxy @Block)
  Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Proxy Inline -> Name
forall a. Data a => Proxy a -> Name
baseFunctionName (Proxy Inline
forall k (t :: k). Proxy t
Proxy @Inline)
  Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Proxy Block -> Name
forall a. Data a => Proxy a -> Name
listFunctionName (Proxy Block
forall k (t :: k). Proxy t
Proxy @Block)
  Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Proxy Inline -> Name
forall a. Data a => Proxy a -> Name
listFunctionName (Proxy Inline
forall k (t :: k). Proxy t
Proxy @Inline)
  Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:  Proxy Inline -> [Name]
forall a. Data a => Proxy a -> [Name]
valueFunctionNames (Proxy Inline
forall k (t :: k). Proxy t
Proxy @Inline)
  [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Proxy Block -> [Name]
forall a. Data a => Proxy a -> [Name]
valueFunctionNames (Proxy Block
forall k (t :: k). Proxy t
Proxy @Block)

-- | Retrieves a `Filter` object from the stack, fetching all functions
-- in the given list of names.
peekFilter' :: LuaError e => [Name] -> Peeker e Filter
peekFilter' :: [Name] -> Peeker e Filter
peekFilter' [Name]
fnNames StackIndex
idx = do
  let go :: Name -> Map Name FilterFunction -> Peek e (Map Name FilterFunction)
go Name
constr Map Name FilterFunction
acc = LuaE e (Map Name FilterFunction)
-> Peek e (Map Name FilterFunction)
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e (Map Name FilterFunction)
 -> Peek e (Map Name FilterFunction))
-> LuaE e (Map Name FilterFunction)
-> Peek e (Map Name FilterFunction)
forall a b. (a -> b) -> a -> b
$ do
        Type
_ <- StackIndex -> Name -> LuaE e Type
forall e. LuaError e => StackIndex -> Name -> LuaE e Type
getfield StackIndex
idx Name
constr
        Peek e FilterFunction -> LuaE e (Result FilterFunction)
forall e a. Peek e a -> LuaE e (Result a)
runPeek (Peeker e FilterFunction
forall e. Peeker e FilterFunction
peekFilterFunction StackIndex
top Peek e FilterFunction -> LuaE e () -> Peek e FilterFunction
forall e a b. Peek e a -> LuaE e b -> Peek e a
`lastly` Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1) LuaE e (Result FilterFunction)
-> (Result FilterFunction -> LuaE e (Map Name FilterFunction))
-> LuaE e (Map Name FilterFunction)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Success FilterFunction
fn -> Map Name FilterFunction -> LuaE e (Map Name FilterFunction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Name FilterFunction -> LuaE e (Map Name FilterFunction))
-> Map Name FilterFunction -> LuaE e (Map Name FilterFunction)
forall a b. (a -> b) -> a -> b
$ Name
-> FilterFunction
-> Map Name FilterFunction
-> Map Name FilterFunction
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
constr FilterFunction
fn Map Name FilterFunction
acc
          Failure {} -> Map Name FilterFunction -> LuaE e (Map Name FilterFunction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Name FilterFunction
acc
  WalkingOrder
walkingSequence <- do
    Type
_ <- LuaE e Type -> Peek e Type
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e Type -> Peek e Type) -> LuaE e Type -> Peek e Type
forall a b. (a -> b) -> a -> b
$ StackIndex -> Name -> LuaE e Type
forall e. LuaError e => StackIndex -> Name -> LuaE e Type
getfield StackIndex
idx Name
"traverse"
    Peek e Text -> Peek e (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Peeker e Text
forall e. Peeker e Text
peekText StackIndex
top) Peek e (Maybe Text) -> LuaE e () -> Peek e (Maybe Text)
forall e a b. Peek e a -> LuaE e b -> Peek e a
`lastly` Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1 Peek e (Maybe Text)
-> (Maybe Text -> Peek e WalkingOrder) -> Peek e WalkingOrder
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Text
"typewise" -> WalkingOrder -> Peek e WalkingOrder
forall (f :: * -> *) a. Applicative f => a -> f a
pure WalkingOrder
WalkForEachType
      Just Text
"topdown"  -> WalkingOrder -> Peek e WalkingOrder
forall (f :: * -> *) a. Applicative f => a -> f a
pure WalkingOrder
WalkTopdown
      Maybe Text
_               -> WalkingOrder -> Peek e WalkingOrder
forall (f :: * -> *) a. Applicative f => a -> f a
pure WalkingOrder
WalkForEachType
  WalkingOrder -> Map Name FilterFunction -> Filter
Filter WalkingOrder
walkingSequence (Map Name FilterFunction -> Filter)
-> Peek e (Map Name FilterFunction) -> Peek e Filter
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (Name
 -> Map Name FilterFunction -> Peek e (Map Name FilterFunction))
-> Map Name FilterFunction
-> [Name]
-> Peek e (Map Name FilterFunction)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Name -> Map Name FilterFunction -> Peek e (Map Name FilterFunction)
forall e.
LuaError e =>
Name -> Map Name FilterFunction -> Peek e (Map Name FilterFunction)
go Map Name FilterFunction
forall k a. Map k a
Map.empty [Name]
fnNames

-- | Looks up a filter function in a Lua 'Filter'.
lookup :: Name -> Filter -> Maybe FilterFunction
lookup :: Name -> Filter -> Maybe FilterFunction
lookup Name
name = (Name
name Name -> Map Name FilterFunction -> Maybe FilterFunction
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup`) (Map Name FilterFunction -> Maybe FilterFunction)
-> (Filter -> Map Name FilterFunction)
-> Filter
-> Maybe FilterFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Filter -> Map Name FilterFunction
filterMap

-- | Checks whether the 'Filter' contains a function of the given name.
member :: Name -> Filter -> Bool
member :: Name -> Filter -> Bool
member Name
name = (Name
name Name -> Map Name FilterFunction -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member`) (Map Name FilterFunction -> Bool)
-> (Filter -> Map Name FilterFunction) -> Filter -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Filter -> Map Name FilterFunction
filterMap

-- | Filter function names for a given type.
valueFunctionNames :: forall a. Data a => Proxy a -> [Name]
valueFunctionNames :: Proxy a -> [Name]
valueFunctionNames Proxy a
_ = (Constr -> Name) -> [Constr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
forall a. IsString a => String -> a
fromString (String -> Name) -> (Constr -> String) -> Constr -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constr -> String
forall a. Show a => a -> String
show) ([Constr] -> [Name]) -> (a -> [Constr]) -> a -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataType -> [Constr]
dataTypeConstrs (DataType -> [Constr]) -> (a -> DataType) -> a -> [Constr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DataType
forall a. Data a => a -> DataType
dataTypeOf
                     (a -> [Name]) -> a -> [Name]
forall a b. (a -> b) -> a -> b
$ (a
forall a. HasCallStack => a
undefined :: a)

-- | The name of a type's base function, which is called if there is no
-- more specific function for a value.
baseFunctionName :: forall a. Data a => Proxy a -> Name
baseFunctionName :: Proxy a -> Name
baseFunctionName Proxy a
_ =
  String -> Name
forall a. IsString a => String -> a
fromString (String -> Name) -> (a -> String) -> a -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
tyconUQname (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataType -> String
dataTypeName (DataType -> String) -> (a -> DataType) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DataType
forall a. Data a => a -> DataType
dataTypeOf
  (a -> Name) -> a -> Name
forall a b. (a -> b) -> a -> b
$ (a
forall a. HasCallStack => a
undefined :: a)

-- | The name of the functions that's called on lists of the given type.
listFunctionName :: forall a. Data a => Proxy a -> Name
listFunctionName :: Proxy a -> Name
listFunctionName Proxy a
_ =
  String -> Name
forall a. IsString a => String -> a
fromString (String -> Name) -> (a -> String) -> a -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"s") (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
tyconUQname (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataType -> String
dataTypeName (DataType -> String) -> (a -> DataType) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DataType
forall a. Data a => a -> DataType
dataTypeOf
  (a -> Name) -> a -> Name
forall a b. (a -> b) -> a -> b
$ (a
forall a. HasCallStack => a
undefined :: a)

-- | Finds the best filter function for a given element; returns
-- 'Nothing' if no such function exists.
getFunctionFor :: forall a. Data a => Filter -> a -> Maybe FilterFunction
getFunctionFor :: Filter -> a -> Maybe FilterFunction
getFunctionFor Filter
filter' a
x =
  let constrName :: Name
constrName = String -> Name
forall a. IsString a => String -> a
fromString (String -> Name) -> (a -> String) -> a -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constr -> String
showConstr (Constr -> String) -> (a -> Constr) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Constr
forall a. Data a => a -> Constr
toConstr (a -> Name) -> a -> Name
forall a b. (a -> b) -> a -> b
$ a
x
      typeName :: Name
typeName = String -> Name
forall a. IsString a => String -> a
fromString (String -> Name) -> (a -> String) -> a -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
tyconUQname (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataType -> String
dataTypeName (DataType -> String) -> (a -> DataType) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DataType
forall a. Data a => a -> DataType
dataTypeOf (a -> Name) -> a -> Name
forall a b. (a -> b) -> a -> b
$ a
x
  in Name
constrName Name -> Filter -> Maybe FilterFunction
`lookup` Filter
filter' Maybe FilterFunction
-> Maybe FilterFunction -> Maybe FilterFunction
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
     Name
typeName   Name -> Filter -> Maybe FilterFunction
`lookup` Filter
filter'