Format.hs

{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TupleSections        #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
   Module      : Text.Pandoc.Lua.Marshaling.Format
   Copyright   : © 2022-2023 Albert Krewinkel
   License     : GPL-2.0-or-later
   Maintainer  : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>

Marshaling functions and instance for format related types, including
'Extensions' and 'ExtensionConfig'.
-}
module Text.Pandoc.Lua.Marshal.Format
  ( peekExtensions
  , pushExtensions
  , peekExtensionsConfig
  , pushExtensionsConfig
  , peekFlavoredFormat
  ) where

import Control.Applicative ((<|>))
import Control.Monad ((<$!>))
import Data.Maybe (fromMaybe)
import HsLua
import Text.Pandoc.Error (PandocError (..))
import Text.Pandoc.Extensions
  ( Extension, Extensions, extensionsFromList, extensionsToList
  , getDefaultExtensions, readExtension, showExtension )
import Text.Pandoc.Format
  ( ExtensionsConfig (..), ExtensionsDiff (..), FlavoredFormat (..)
  , diffExtensions, parseFlavoredFormat)
import Text.Pandoc.Lua.PandocLua (PandocLua (unPandocLua))

-- | Retrieves a single 'Extension' from the Lua stack.
peekExtension :: LuaError e => Peeker e Extension
peekExtension idx = do
  extString <- peekString idx
  return $ readExtension extString
{-# INLINE peekExtension #-}

-- | Pushes an individual 'Extension' to the Lua stack.
pushExtension :: LuaError e => Pusher e Extension
pushExtension = pushText . showExtension
{-# INLINE pushExtension #-}

-- | Retrieves an 'Extensions' set from the Lua stack.
peekExtensions :: LuaError e => Peeker e Extensions
peekExtensions = fmap extensionsFromList . peekList peekExtension
{-# INLINE peekExtensions #-}

-- | Pushes a set of 'Extensions' to the top of the Lua stack.
pushExtensions :: LuaError e => Pusher e Extensions
pushExtensions = pushViaJSON
{-# INLINE pushExtensions #-}

instance Peekable Extensions where
  safepeek = peekExtensions

instance Pushable Extensions where
  push = pushExtensions

-- | Retrieves an 'ExtensionsConfig' value from the Lua stack.
peekExtensionsConfig :: LuaError e => Peeker e ExtensionsConfig
peekExtensionsConfig idx = do
  diff <- peekExtensionsDiff idx
  return $ ExtensionsConfig
    { extsDefault   = extsToEnable diff
    , extsSupported = extsToEnable diff <> extsToDisable diff
    }

-- | Pushes an 'ExtensionsConfig' value as a table with that maps
-- extensions to their default enabled/disabled status.
pushExtensionsConfig :: LuaError e => Pusher e ExtensionsConfig
pushExtensionsConfig (ExtensionsConfig def supported) =
  pushKeyValuePairs pushExtension pushBool $
    map (,False) (extensionsToList supported) ++
    map (,True)  (extensionsToList def)

instance Peekable ExtensionsConfig where
  safepeek = peekExtensionsConfig

peekExtensionsDiff :: LuaError e => Peeker e ExtensionsDiff
peekExtensionsDiff = typeChecked "table" istable $ \idx ->
      (do
          en <- peekFieldRaw (emptyOr (fmap Just . peekExtensions)) "enable" idx
          di <- peekFieldRaw (emptyOr (fmap Just . peekExtensions)) "disable" idx
          if (en, di) == (Nothing, Nothing)
            then failPeek "At least on of  'enable' and 'disable' must be set"
            else return $
                 ExtensionsDiff (fromMaybe mempty en) (fromMaybe mempty di))
  <|> -- two lists of extensions; the first is list assumed to contain those
      -- extensions to be enabled
      (uncurry ExtensionsDiff <$!> peekPair peekExtensions peekExtensions idx)
  <|> (do
          let
          exts <- peekKeyValuePairs peekExtension peekEnabled idx
          let enabled  = extensionsFromList . map fst $ filter snd exts
          let disabled = extensionsFromList . map fst $ filter (not . snd) exts
          return $ ExtensionsDiff enabled disabled)

-- | Retrieves the activation status of an extension. True or the string
-- @'enable'@ for activated, False or 'disable' for disabled.
peekEnabled :: LuaError e => Peeker e Bool
peekEnabled idx' = liftLua (ltype idx') >>= \case
  TypeBoolean -> peekBool idx'
  TypeString  -> peekText idx' >>= \case
                   "disable" -> pure False
                   "enable"  -> pure True
                   _         -> failPeek "expected 'disable' or 'enable'"
  _ -> failPeek "expected boolean or string"

-- | Retrieves a flavored format from the Lua stack.
peekFlavoredFormat :: Peeker PandocError FlavoredFormat
peekFlavoredFormat idx = retrieving "flavored format" $
  liftLua (ltype idx) >>= \case
  TypeString -> peekText idx >>= liftLua . unPandocLua . parseFlavoredFormat
  TypeTable -> do
    let diffFor format idx' = peekExtensionsDiff idx' <|>
          (getDefaultExtensions format `diffExtensions`) <$>
          (typeChecked "table" istable peekExtensions idx')
    format   <- peekFieldRaw peekText "format" idx
    extsDiff <- peekFieldRaw (emptyOr (diffFor format)) "extensions" idx
    return (FlavoredFormat format extsDiff)
  _ -> failPeek =<< typeMismatchMessage "string or table" idx

-- | Returns 'mempty' if the given stack index is @nil@, and the result
-- of the peeker otherwise.
emptyOr :: Monoid a => Peeker e a -> Peeker e a
emptyOr p idx = do
  nil <- liftLua (isnil idx)
  if nil
    then pure mempty
    else p idx