{-# 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
  , formatFromFilePaths
  ) where

import Control.Monad.Except (throwError)
import Data.Char (toLower)
import Data.Foldable (asum)
import Data.List (foldl')
import System.FilePath (splitExtension, takeExtension)
import Text.Pandoc.Class (PandocMonad)
import Text.Pandoc.Error (PandocError (..))
import Text.Pandoc.Extensions
  ( Extension (Ext_literate_haskell)
  , Extensions
  , disableExtensions
  , enableExtension
  , extensionsFromList
  , 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FlavoredFormat] -> ShowS
$cshowList :: [FlavoredFormat] -> ShowS
show :: FlavoredFormat -> String
$cshow :: FlavoredFormat -> String
showsPrec :: Int -> FlavoredFormat -> ShowS
$cshowsPrec :: Int -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtensionsDiff] -> ShowS
$cshowList :: [ExtensionsDiff] -> ShowS
show :: ExtensionsDiff -> String
$cshow :: ExtensionsDiff -> String
showsPrec :: Int -> ExtensionsDiff -> ShowS
$cshowsPrec :: Int -> 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) forall a. Semigroup a => a -> a -> a
<> Extensions
enB)
    ((Extensions
disA Extensions -> Extensions -> Extensions
`disableExtensions` Extensions
enB) forall a. Semigroup a => a -> a -> a
<> Extensions
disB)

instance Monoid ExtensionsDiff where
  mempty :: ExtensionsDiff
mempty = Extensions -> Extensions -> ExtensionsDiff
ExtensionsDiff forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  mappend :: ExtensionsDiff -> ExtensionsDiff -> ExtensionsDiff
mappend = 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtensionsConfig] -> ShowS
$cshowList :: [ExtensionsConfig] -> ShowS
show :: ExtensionsConfig -> String
$cshow :: ExtensionsConfig -> String
showsPrec :: Int -> ExtensionsConfig -> ShowS
$cshowsPrec :: Int -> 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 forall a. Semigroup a => a -> a -> a
<> Extensions
x2) (Extensions
y1 forall a. Semigroup a => a -> a -> a
<> Extensions
y2)

instance Monoid ExtensionsConfig where
  mappend :: ExtensionsConfig -> ExtensionsConfig -> ExtensionsConfig
mappend = forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: ExtensionsConfig
mempty = Extensions -> Extensions -> ExtensionsConfig
ExtensionsConfig forall a. Monoid a => a
mempty 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 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]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Text -> PandocError
PandocUnsupportedExtensionError
             (Extension -> Text
showExtension Extension
ext) Text
fname
    []    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ExtensionsConfig -> Extensions
extsDefault ExtensionsConfig
extConf Extensions -> Extensions -> Extensions
`disableExtensions`
                    ExtensionsDiff -> Extensions
extsToDisable ExtensionsDiff
extsDiff) 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 forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (forall {s} {u}. ParsecT s u Identity ()
fixSourcePos forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall {u}. ParsecT Text u Identity (Text, ExtensionsDiff)
formatSpec) String
"" Text
spec' of
    Right (Text
fname, ExtensionsDiff
extsDiff) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ExtensionsDiff -> FlavoredFormat
FlavoredFormat (Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
fname) ExtensionsDiff
extsDiff)
    Left ParseError
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Text -> PandocError
PandocFormatError Text
spec (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ParseError
err)
  where
    fixSourcePos :: ParsecT s u Identity ()
fixSourcePos = do
      SourcePos
pos <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
      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 <- forall {u}. ParsecT Text u Identity String
parseFormatName
      ExtensionsDiff
extsDiff <- forall s (m :: * -> *) u.
(UpdateSourcePos s Char, Stream s m Char) =>
ParsecT s u m ExtensionsDiff
pExtensionsDiff
      forall (m :: * -> *) a. Monad m => a -> m a
return ( String -> Text
T.pack String
name, ExtensionsDiff
extsDiff )
    parseFormatName :: ParsecT Text u Identity String
parseFormatName = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)) forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall {u}. ParsecT s u m (ExtensionsDiff -> ExtensionsDiff)
extMod
  where
    extMod :: ParsecT s u m (ExtensionsDiff -> ExtensionsDiff)
extMod = do
      Char
polarity <- forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m Char
oneOf String
"-+"
      String
name <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall a b. (a -> b) -> a -> b
$ 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
      forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$
                                          ExtensionsDiff -> Extensions
extsToEnable ExtensionsDiff
extsDiff}
          Char
_   -> ExtensionsDiff
extsDiff{extsToDisable :: Extensions
extsToDisable = Extension -> Extensions -> Extensions
enableExtension Extension
ext forall a b. (a -> b) -> a -> b
$
                                          ExtensionsDiff -> Extensions
extsToDisable ExtensionsDiff
extsDiff}

-- | Determines default format based on file extensions; uses the format
-- of the first extension that's associated with a format.
--
-- Examples:
--
-- > formatFromFilePaths ["text.unknown", "no-extension"]
-- Nothing
--
-- > formatFromFilePaths ["my.md", "other.rst"]
-- Just "markdown"
formatFromFilePaths :: [FilePath] -> (Maybe FlavoredFormat)
formatFromFilePaths :: [String] -> Maybe FlavoredFormat
formatFromFilePaths = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe FlavoredFormat
formatFromFilePath

-- | Determines format based on file extension.
formatFromFilePath :: FilePath -> Maybe FlavoredFormat
formatFromFilePath :: String -> Maybe FlavoredFormat
formatFromFilePath String
x =
  case ShowS
takeExtension (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x) of
    String
".Rmd"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"markdown"
    String
".adoc"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"asciidoc"
    String
".asciidoc" -> Text -> Maybe FlavoredFormat
defFlavor Text
"asciidoc"
    String
".bib"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"biblatex"
    String
".context"  -> Text -> Maybe FlavoredFormat
defFlavor Text
"context"
    String
".csv"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"csv"
    String
".ctx"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"context"
    String
".db"       -> Text -> Maybe FlavoredFormat
defFlavor Text
"docbook"
    String
".doc"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"doc"  -- so we get an "unknown reader" error
    String
".docx"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"docx"
    String
".dokuwiki" -> Text -> Maybe FlavoredFormat
defFlavor Text
"dokuwiki"
    String
".epub"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"epub"
    String
".fb2"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"fb2"
    String
".htm"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"html"
    String
".html"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"html"
    String
".icml"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"icml"
    String
".ipynb"    -> Text -> Maybe FlavoredFormat
defFlavor Text
"ipynb"
    String
".json"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"json"
    String
".latex"    -> Text -> Maybe FlavoredFormat
defFlavor Text
"latex"
    String
".lhs"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"markdown" Maybe FlavoredFormat -> Extension -> Maybe FlavoredFormat
`withExtension` Extension
Ext_literate_haskell
    String
".ltx"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"latex"
    String
".markdown" -> Text -> Maybe FlavoredFormat
defFlavor Text
"markdown"
    String
".markua"   -> Text -> Maybe FlavoredFormat
defFlavor Text
"markua"
    String
".md"       -> Text -> Maybe FlavoredFormat
defFlavor Text
"markdown"
    String
".mdown"    -> Text -> Maybe FlavoredFormat
defFlavor Text
"markdown"
    String
".mdwn"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"markdown"
    String
".mkd"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"markdown"
    String
".mkdn"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"markdown"
    String
".ms"       -> Text -> Maybe FlavoredFormat
defFlavor Text
"ms"
    String
".muse"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"muse"
    String
".native"   -> Text -> Maybe FlavoredFormat
defFlavor Text
"native"
    String
".odt"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"odt"
    String
".opml"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"opml"
    String
".org"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"org"
    String
".pdf"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"pdf"  -- so we get an "unknown reader" error
    String
".pptx"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"pptx"
    String
".ris"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"ris"
    String
".roff"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"ms"
    String
".rst"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"rst"
    String
".rtf"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"rtf"
    String
".s5"       -> Text -> Maybe FlavoredFormat
defFlavor Text
"s5"
    String
".t2t"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"t2t"
    String
".tei"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"tei"
    String
".tex"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"latex"
    String
".texi"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"texinfo"
    String
".texinfo"  -> Text -> Maybe FlavoredFormat
defFlavor Text
"texinfo"
    String
".text"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"markdown"
    String
".textile"  -> Text -> Maybe FlavoredFormat
defFlavor Text
"textile"
    String
".tsv"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"tsv"
    String
".typ"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"typst"
    String
".txt"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"markdown"
    String
".typ"      -> Text -> Maybe FlavoredFormat
defFlavor Text
"typst"
    String
".wiki"     -> Text -> Maybe FlavoredFormat
defFlavor Text
"mediawiki"
    String
".xhtml"    -> Text -> Maybe FlavoredFormat
defFlavor Text
"html"
    [Char
'.',Char
y]     | Char
y forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'1'..Char
'9'] -> Text -> Maybe FlavoredFormat
defFlavor Text
"man"
    String
_           -> forall a. Maybe a
Nothing
 where
  defFlavor :: Text -> Maybe FlavoredFormat
defFlavor Text
f = forall a. a -> Maybe a
Just (Text -> ExtensionsDiff -> FlavoredFormat
FlavoredFormat Text
f forall a. Monoid a => a
mempty)
  withExtension :: Maybe FlavoredFormat -> Extension -> Maybe FlavoredFormat
withExtension Maybe FlavoredFormat
Nothing Extension
_ = forall a. Maybe a
Nothing
  withExtension (Just (FlavoredFormat Text
f ExtensionsDiff
ed)) Extension
ext = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
    Text -> ExtensionsDiff -> FlavoredFormat
FlavoredFormat Text
f (ExtensionsDiff
ed forall a. Semigroup a => a -> a -> a
<> Extensions -> Extensions -> ExtensionsDiff
ExtensionsDiff ([Extension] -> Extensions
extensionsFromList [Extension
ext]) forall a. Monoid a => a
mempty)