{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Format
   Copyright   : © 2022-2023 Albert Krewinkel
   License     : GPL-2.0-or-later
   Maintainer  : Albert Krewinkel <pandoc@tarleb.com>

Handling of format specifiers for input and output.
-}
module Text.Pandoc.Format
  ( FlavoredFormat (..)
  , ExtensionsConfig (..)
  , ExtensionsDiff (..)
  , diffExtensions
  , parseFlavoredFormat
  , applyExtensionsDiff
  , getExtensionsConfig
  ) where

import Control.Monad.Except (throwError)
import Data.List (foldl')
import System.FilePath (splitExtension)
import Text.Pandoc.Class (PandocMonad)
import Text.Pandoc.Error (PandocError (..))
import Text.Pandoc.Extensions
  ( Extensions
  , disableExtensions
  , enableExtension
  , extensionsToList
  , getAllExtensions
  , getDefaultExtensions
  , showExtension
  , readExtension
  )
import Text.Pandoc.Parsing
import qualified Data.Text as T

-- | Format specifier with the format's name and the lists of extensions
-- to be enabled or disabled.
data FlavoredFormat = FlavoredFormat
  { FlavoredFormat -> Text
formatName     :: T.Text
  , FlavoredFormat -> ExtensionsDiff
formatExtsDiff :: ExtensionsDiff
  } deriving (Int -> FlavoredFormat -> ShowS
[FlavoredFormat] -> ShowS
FlavoredFormat -> String
(Int -> FlavoredFormat -> ShowS)
-> (FlavoredFormat -> String)
-> ([FlavoredFormat] -> ShowS)
-> Show FlavoredFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FlavoredFormat -> ShowS
showsPrec :: Int -> FlavoredFormat -> ShowS
$cshow :: FlavoredFormat -> String
show :: FlavoredFormat -> String
$cshowList :: [FlavoredFormat] -> ShowS
showList :: [FlavoredFormat] -> ShowS
Show)

-- | Changes to a set of extensions, i.e., list of extensions to be
-- enabled or disabled.
data ExtensionsDiff = ExtensionsDiff
  { ExtensionsDiff -> Extensions
extsToEnable  :: Extensions
  , ExtensionsDiff -> Extensions
extsToDisable :: Extensions
  } deriving (Int -> ExtensionsDiff -> ShowS
[ExtensionsDiff] -> ShowS
ExtensionsDiff -> String
(Int -> ExtensionsDiff -> ShowS)
-> (ExtensionsDiff -> String)
-> ([ExtensionsDiff] -> ShowS)
-> Show ExtensionsDiff
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExtensionsDiff -> ShowS
showsPrec :: Int -> ExtensionsDiff -> ShowS
$cshow :: ExtensionsDiff -> String
show :: ExtensionsDiff -> String
$cshowList :: [ExtensionsDiff] -> ShowS
showList :: [ExtensionsDiff] -> ShowS
Show)

instance Semigroup ExtensionsDiff where
  ExtensionsDiff Extensions
enA Extensions
disA <> :: ExtensionsDiff -> ExtensionsDiff -> ExtensionsDiff
<> ExtensionsDiff Extensions
enB Extensions
disB =
    Extensions -> Extensions -> ExtensionsDiff
ExtensionsDiff
    ((Extensions
enA Extensions -> Extensions -> Extensions
`disableExtensions` Extensions
disB) Extensions -> Extensions -> Extensions
forall a. Semigroup a => a -> a -> a
<> Extensions
enB)
    ((Extensions
disA Extensions -> Extensions -> Extensions
`disableExtensions` Extensions
enB) Extensions -> Extensions -> Extensions
forall a. Semigroup a => a -> a -> a
<> Extensions
disB)

instance Monoid ExtensionsDiff where
  mempty :: ExtensionsDiff
mempty = Extensions -> Extensions -> ExtensionsDiff
ExtensionsDiff Extensions
forall a. Monoid a => a
mempty Extensions
forall a. Monoid a => a
mempty
  mappend :: ExtensionsDiff -> ExtensionsDiff -> ExtensionsDiff
mappend = ExtensionsDiff -> ExtensionsDiff -> ExtensionsDiff
forall a. Semigroup a => a -> a -> a
(<>)

-- | Calculate the change set to get from one set of extensions to
-- another.
diffExtensions :: Extensions -> Extensions -> ExtensionsDiff
diffExtensions :: Extensions -> Extensions -> ExtensionsDiff
diffExtensions Extensions
def Extensions
actual = ExtensionsDiff
  { extsToEnable :: Extensions
extsToEnable = Extensions
actual Extensions -> Extensions -> Extensions
`disableExtensions` Extensions
def
  , extsToDisable :: Extensions
extsToDisable = Extensions
def Extensions -> Extensions -> Extensions
`disableExtensions` Extensions
actual
  }

-- | Describes the properties of a format.
data ExtensionsConfig = ExtensionsConfig
  { ExtensionsConfig -> Extensions
extsDefault   :: Extensions -- ^ Extensions enabled by default
  , ExtensionsConfig -> Extensions
extsSupported :: Extensions -- ^ Extensions that can be enabled or disabled.
  } deriving (Int -> ExtensionsConfig -> ShowS
[ExtensionsConfig] -> ShowS
ExtensionsConfig -> String
(Int -> ExtensionsConfig -> ShowS)
-> (ExtensionsConfig -> String)
-> ([ExtensionsConfig] -> ShowS)
-> Show ExtensionsConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExtensionsConfig -> ShowS
showsPrec :: Int -> ExtensionsConfig -> ShowS
$cshow :: ExtensionsConfig -> String
show :: ExtensionsConfig -> String
$cshowList :: [ExtensionsConfig] -> ShowS
showList :: [ExtensionsConfig] -> ShowS
Show)

-- | Returns the extensions configuration of a format.
getExtensionsConfig :: T.Text -> ExtensionsConfig
getExtensionsConfig :: Text -> ExtensionsConfig
getExtensionsConfig Text
fmt = ExtensionsConfig
  { extsDefault :: Extensions
extsDefault = Text -> Extensions
getDefaultExtensions Text
fmt
  , extsSupported :: Extensions
extsSupported = Text -> Extensions
getAllExtensions Text
fmt
  }

instance Semigroup ExtensionsConfig where
  ExtensionsConfig Extensions
x1 Extensions
y1 <> :: ExtensionsConfig -> ExtensionsConfig -> ExtensionsConfig
<> ExtensionsConfig Extensions
x2 Extensions
y2 =
    Extensions -> Extensions -> ExtensionsConfig
ExtensionsConfig (Extensions
x1 Extensions -> Extensions -> Extensions
forall a. Semigroup a => a -> a -> a
<> Extensions
x2) (Extensions
y1 Extensions -> Extensions -> Extensions
forall a. Semigroup a => a -> a -> a
<> Extensions
y2)

instance Monoid ExtensionsConfig where
  mappend :: ExtensionsConfig -> ExtensionsConfig -> ExtensionsConfig
mappend = ExtensionsConfig -> ExtensionsConfig -> ExtensionsConfig
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: ExtensionsConfig
mempty = Extensions -> Extensions -> ExtensionsConfig
ExtensionsConfig Extensions
forall a. Monoid a => a
mempty Extensions
forall a. Monoid a => a
mempty

-- | Apply the extension changes in the format spec to the extensions
-- given in the format's extensions configuration. Throws an error in
-- case of an unknown or unsupported extension.
applyExtensionsDiff :: PandocMonad m
                    => ExtensionsConfig
                    -> FlavoredFormat
                    -> m Extensions
applyExtensionsDiff :: forall (m :: * -> *).
PandocMonad m =>
ExtensionsConfig -> FlavoredFormat -> m Extensions
applyExtensionsDiff ExtensionsConfig
extConf (FlavoredFormat Text
fname ExtensionsDiff
extsDiff) = do
  let extsInDiff :: Extensions
extsInDiff  = ExtensionsDiff -> Extensions
extsToEnable ExtensionsDiff
extsDiff Extensions -> Extensions -> Extensions
forall a. Semigroup a => a -> a -> a
<> ExtensionsDiff -> Extensions
extsToDisable ExtensionsDiff
extsDiff
  let unsupported :: Extensions
unsupported = Extensions
extsInDiff Extensions -> Extensions -> Extensions
`disableExtensions` (ExtensionsConfig -> Extensions
extsSupported ExtensionsConfig
extConf)
  case Extensions -> [Extension]
extensionsToList Extensions
unsupported of
    Extension
ext:[Extension]
_ -> PandocError -> m Extensions
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m Extensions) -> PandocError -> m Extensions
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PandocError
PandocUnsupportedExtensionError
             (Extension -> Text
showExtension Extension
ext) Text
fname
    []    -> Extensions -> m Extensions
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ExtensionsConfig -> Extensions
extsDefault ExtensionsConfig
extConf Extensions -> Extensions -> Extensions
`disableExtensions`
                    ExtensionsDiff -> Extensions
extsToDisable ExtensionsDiff
extsDiff) Extensions -> Extensions -> Extensions
forall a. Semigroup a => a -> a -> a
<> ExtensionsDiff -> Extensions
extsToEnable ExtensionsDiff
extsDiff)

-- | Parse a format-specifying string into a markup format and the
-- change set to the format's extensions. Throws an error if the spec
-- cannot be parsed or contains an unknown extension.
parseFlavoredFormat :: PandocMonad m
                    => T.Text
                    -> m FlavoredFormat
parseFlavoredFormat :: forall (m :: * -> *). PandocMonad m => Text -> m FlavoredFormat
parseFlavoredFormat Text
spec =
  -- Paths like `latex-foo-bar.lua` or `latex-smart-citations.lua`
  -- should be parsed as the format name. The `-` (or `+`) in the
  -- filename would confuse the extensions parser, so, if `spec` looks
  -- like a filename, the file's basename is split off into the prefix.
  -- Only the remaining part is parsed, and the prefix is appended back
  -- to the format after parsing.
  case Parsec Text () (Text, ExtensionsDiff)
-> String -> Text -> Either ParseError (Text, ExtensionsDiff)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (ParsecT Text () Identity ()
forall {s} {u}. ParsecT s u Identity ()
fixSourcePos ParsecT Text () Identity ()
-> Parsec Text () (Text, ExtensionsDiff)
-> Parsec Text () (Text, ExtensionsDiff)
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Text () (Text, ExtensionsDiff)
forall {u}. ParsecT Text u Identity (Text, ExtensionsDiff)
formatSpec) String
"" Text
spec' of
    Right (Text
fname, ExtensionsDiff
extsDiff) -> FlavoredFormat -> m FlavoredFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ExtensionsDiff -> FlavoredFormat
FlavoredFormat (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fname) ExtensionsDiff
extsDiff)
    Left ParseError
err -> PandocError -> m FlavoredFormat
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m FlavoredFormat)
-> PandocError -> m FlavoredFormat
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PandocError
PandocFormatError Text
spec (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
err)
  where
    fixSourcePos :: ParsecT s u Identity ()
fixSourcePos = do
      SourcePos
pos <- ParsecT s u Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
      SourcePos -> ParsecT s u Identity ()
forall (m :: * -> *) s u. Monad m => SourcePos -> ParsecT s u m ()
setPosition (SourcePos -> Int -> SourcePos
incSourceColumn SourcePos
pos (Text -> Int
T.length Text
prefix))
    formatSpec :: ParsecT Text u Identity (Text, ExtensionsDiff)
formatSpec = do
      String
name <- ParsecT Text u Identity String
forall {u}. ParsecT Text u Identity String
parseFormatName
      ExtensionsDiff
extsDiff <- ParsecT Text u Identity ExtensionsDiff
forall s (m :: * -> *) u.
(UpdateSourcePos s Char, Stream s m Char) =>
ParsecT s u m ExtensionsDiff
pExtensionsDiff
      (Text, ExtensionsDiff)
-> ParsecT Text u Identity (Text, ExtensionsDiff)
forall a. a -> ParsecT Text u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ( String -> Text
T.pack String
name, ExtensionsDiff
extsDiff )
    parseFormatName :: ParsecT Text u Identity String
parseFormatName = ParsecT Text u Identity Char -> ParsecT Text u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT Text u Identity Char -> ParsecT Text u Identity String)
-> ParsecT Text u Identity Char -> ParsecT Text u Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT Text u Identity Char
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m Char
noneOf String
"-+"
    (Text
prefix, Text
spec') = case String -> (String, String)
splitExtension (Text -> String
T.unpack Text
spec) of
                        (String
_, String
"") -> (Text
"", Text -> Text
T.toLower Text
spec) -- no extension
                        (String
p,String
s)   -> (String -> Text
T.pack String
p, String -> Text
T.pack String
s)

pExtensionsDiff :: (UpdateSourcePos s Char, Stream s m Char)
                => ParsecT s u m ExtensionsDiff
pExtensionsDiff :: forall s (m :: * -> *) u.
(UpdateSourcePos s Char, Stream s m Char) =>
ParsecT s u m ExtensionsDiff
pExtensionsDiff = (ExtensionsDiff
 -> (ExtensionsDiff -> ExtensionsDiff) -> ExtensionsDiff)
-> ExtensionsDiff
-> [ExtensionsDiff -> ExtensionsDiff]
-> ExtensionsDiff
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((ExtensionsDiff -> ExtensionsDiff)
 -> ExtensionsDiff -> ExtensionsDiff)
-> ExtensionsDiff
-> (ExtensionsDiff -> ExtensionsDiff)
-> ExtensionsDiff
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ExtensionsDiff -> ExtensionsDiff)
-> ExtensionsDiff -> ExtensionsDiff
forall a b. (a -> b) -> a -> b
($)) ExtensionsDiff
forall a. Monoid a => a
mempty ([ExtensionsDiff -> ExtensionsDiff] -> ExtensionsDiff)
-> ParsecT s u m [ExtensionsDiff -> ExtensionsDiff]
-> ParsecT s u m ExtensionsDiff
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s u m (ExtensionsDiff -> ExtensionsDiff)
-> ParsecT s u m [ExtensionsDiff -> ExtensionsDiff]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT s u m (ExtensionsDiff -> ExtensionsDiff)
forall {u}. ParsecT s u m (ExtensionsDiff -> ExtensionsDiff)
extMod
  where
    extMod :: ParsecT s u m (ExtensionsDiff -> ExtensionsDiff)
extMod = do
      Char
polarity <- String -> ParsecT s u m Char
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m Char
oneOf String
"-+"
      String
name <- ParsecT s u m Char -> ParsecT s u m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT s u m Char -> ParsecT s u m String)
-> ParsecT s u m Char -> ParsecT s u m String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT s u m Char
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m Char
noneOf String
"-+"
      let ext :: Extension
ext = String -> Extension
readExtension String
name
      (ExtensionsDiff -> ExtensionsDiff)
-> ParsecT s u m (ExtensionsDiff -> ExtensionsDiff)
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ExtensionsDiff -> ExtensionsDiff)
 -> ParsecT s u m (ExtensionsDiff -> ExtensionsDiff))
-> (ExtensionsDiff -> ExtensionsDiff)
-> ParsecT s u m (ExtensionsDiff -> ExtensionsDiff)
forall a b. (a -> b) -> a -> b
$ \ExtensionsDiff
extsDiff ->
        case Char
polarity of
          Char
'+' -> ExtensionsDiff
extsDiff{extsToEnable :: Extensions
extsToEnable  = Extension -> Extensions -> Extensions
enableExtension Extension
ext (Extensions -> Extensions) -> Extensions -> Extensions
forall a b. (a -> b) -> a -> b
$
                                          ExtensionsDiff -> Extensions
extsToEnable ExtensionsDiff
extsDiff}
          Char
_   -> ExtensionsDiff
extsDiff{extsToDisable :: Extensions
extsToDisable = Extension -> Extensions -> Extensions
enableExtension Extension
ext (Extensions -> Extensions) -> Extensions -> Extensions
forall a b. (a -> b) -> a -> b
$
                                          ExtensionsDiff -> Extensions
extsToDisable ExtensionsDiff
extsDiff}