{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.Roff
   Copyright   : Copyright (C) 2007-2022 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Common functions for roff writers (man, ms).
-}

module Text.Pandoc.Writers.Roff (
      WriterState(..)
    , defaultWriterState
    , MS
    , Note
    , EscapeMode(..)
    , escapeString
    , withFontFeature
    ) where
import Data.Char (ord, isAscii)
import Control.Monad.State.Strict
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Data.String
import Data.Maybe (fromMaybe, isJust, catMaybes)
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Definition
import Text.DocLayout
import Text.Printf (printf)
import Text.Pandoc.RoffChar (standardEscapes,
                              characterCodes, combiningAccents)

data WriterState = WriterState { WriterState -> Bool
stHasInlineMath :: Bool
                               , WriterState -> Bool
stFirstPara     :: Bool
                               , WriterState -> [Note]
stNotes         :: [Note]
                               , WriterState -> Bool
stSmallCaps     :: Bool
                               , WriterState -> Bool
stHighlighting  :: Bool
                               , WriterState -> Bool
stInHeader      :: Bool
                               , WriterState -> Map Char Bool
stFontFeatures  :: Map.Map Char Bool
                               , WriterState -> Bool
stHasTables     :: Bool
                               }

defaultWriterState :: WriterState
defaultWriterState :: WriterState
defaultWriterState = WriterState{ stHasInlineMath :: Bool
stHasInlineMath = Bool
False
                                , stFirstPara :: Bool
stFirstPara     = Bool
True
                                , stNotes :: [Note]
stNotes         = []
                                , stSmallCaps :: Bool
stSmallCaps     = Bool
False
                                , stHighlighting :: Bool
stHighlighting  = Bool
False
                                , stInHeader :: Bool
stInHeader      = Bool
False
                                , stFontFeatures :: Map Char Bool
stFontFeatures  = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
                                                       (Char
'I',Bool
False)
                                                     , (Char
'B',Bool
False)
                                                     , (Char
'C',Bool
False)
                                                     , (Char
'V',Bool
False)
                                                     ]
                                , stHasTables :: Bool
stHasTables     = Bool
False
                                }

type Note = [Block]

type MS = StateT WriterState

data EscapeMode = AllowUTF8        -- ^ use preferred man escapes
                | AsciiOnly        -- ^ escape everything
                deriving Int -> EscapeMode -> ShowS
[EscapeMode] -> ShowS
EscapeMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EscapeMode] -> ShowS
$cshowList :: [EscapeMode] -> ShowS
show :: EscapeMode -> String
$cshow :: EscapeMode -> String
showsPrec :: Int -> EscapeMode -> ShowS
$cshowsPrec :: Int -> EscapeMode -> ShowS
Show

combiningAccentsMap :: Map.Map Char Text
combiningAccentsMap :: Map Char Text
combiningAccentsMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Char, Text)]
combiningAccents

essentialEscapes :: Map.Map Char Text
essentialEscapes :: Map Char Text
essentialEscapes = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Char, Text)]
standardEscapes

-- | Escape special characters for roff.
escapeString :: EscapeMode -> Text -> Text
escapeString :: EscapeMode -> Text -> Text
escapeString EscapeMode
e = [Text] -> Text
Text.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. EscapeMode -> String -> [Text]
escapeString' EscapeMode
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
  where
    escapeString' :: EscapeMode -> String -> [Text]
escapeString' EscapeMode
_ [] = []
    escapeString' EscapeMode
escapeMode (Char
'\n':Char
'.':String
xs) =
      Text
"\n\\&." forall a. a -> [a] -> [a]
: EscapeMode -> String -> [Text]
escapeString' EscapeMode
escapeMode String
xs
    escapeString' EscapeMode
escapeMode (Char
x:String
xs) =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
x Map Char Text
essentialEscapes of
        Just Text
s  -> Text
s forall a. a -> [a] -> [a]
: EscapeMode -> String -> [Text]
escapeString' EscapeMode
escapeMode String
xs
        Maybe Text
Nothing
          | Char -> Bool
isAscii Char
x -> Char -> Text
Text.singleton Char
x forall a. a -> [a] -> [a]
: EscapeMode -> String -> [Text]
escapeString' EscapeMode
escapeMode String
xs
          | Bool
otherwise ->
              case EscapeMode
escapeMode of
                EscapeMode
AllowUTF8 -> Char -> Text
Text.singleton Char
x forall a. a -> [a] -> [a]
: EscapeMode -> String -> [Text]
escapeString' EscapeMode
escapeMode String
xs
                EscapeMode
AsciiOnly ->
                  let accents :: [Text]
accents = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile forall a. Maybe a -> Bool
isJust
                        (forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Char Text
combiningAccentsMap) String
xs)
                      rest :: String
rest = forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
accents) String
xs
                      s :: Text
s = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
x Map Char Text
characterCodeMap of
                            Just Text
t  -> Text
"\\[" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords (Text
tforall a. a -> [a] -> [a]
:[Text]
accents) forall a. Semigroup a => a -> a -> a
<> Text
"]"
                            Maybe Text
Nothing -> Text
"\\[" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords
                              (String -> Text
Text.pack (forall r. PrintfType r => String -> r
printf String
"u%04X" (Char -> Int
ord Char
x)) forall a. a -> [a] -> [a]
: [Text]
accents) forall a. Semigroup a => a -> a -> a
<> Text
"]"
                  in  Text
s forall a. a -> [a] -> [a]
: EscapeMode -> String -> [Text]
escapeString' EscapeMode
escapeMode String
rest

characterCodeMap :: Map.Map Char Text
characterCodeMap :: Map Char Text
characterCodeMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Char, Text)]
characterCodes

fontChange :: (HasChars a, IsString a, PandocMonad m) => MS m (Doc a)
fontChange :: forall a (m :: * -> *).
(HasChars a, IsString a, PandocMonad m) =>
MS m (Doc a)
fontChange = do
  Map Char Bool
features <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Char Bool
stFontFeatures
  Bool
inHeader <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stInHeader
  let filling :: String
filling = [Char
'C' | forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
'C' Map Char Bool
features] forall a. [a] -> [a] -> [a]
++
                [Char
'V' | forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
'V' Map Char Bool
features] forall a. [a] -> [a] -> [a]
++
                [Char
'B' | Bool
inHeader Bool -> Bool -> Bool
||
                       forall a. a -> Maybe a -> a
fromMaybe Bool
False (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
'B' Map Char Bool
features)] forall a. [a] -> [a] -> [a]
++
                [Char
'I' | forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
'I' Map Char Bool
features]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
filling
       then forall a. HasChars a => String -> Doc a
text String
"\\f[R]"
       else forall a. HasChars a => String -> Doc a
text forall a b. (a -> b) -> a -> b
$ String
"\\f[" forall a. [a] -> [a] -> [a]
++ String
filling forall a. [a] -> [a] -> [a]
++ String
"]"

withFontFeature :: (HasChars a, IsString a, PandocMonad m)
                => Char -> MS m (Doc a) -> MS m (Doc a)
withFontFeature :: forall a (m :: * -> *).
(HasChars a, IsString a, PandocMonad m) =>
Char -> MS m (Doc a) -> MS m (Doc a)
withFontFeature Char
c MS m (Doc a)
action = do
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st{ stFontFeatures :: Map Char Bool
stFontFeatures = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust Bool -> Bool
not Char
c forall a b. (a -> b) -> a -> b
$ WriterState -> Map Char Bool
stFontFeatures WriterState
st }
  Doc a
begin <- forall a (m :: * -> *).
(HasChars a, IsString a, PandocMonad m) =>
MS m (Doc a)
fontChange
  Doc a
d <- MS m (Doc a)
action
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st{ stFontFeatures :: Map Char Bool
stFontFeatures = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust Bool -> Bool
not Char
c forall a b. (a -> b) -> a -> b
$ WriterState -> Map Char Bool
stFontFeatures WriterState
st }
  Doc a
end <- forall a (m :: * -> *).
(HasChars a, IsString a, PandocMonad m) =>
MS m (Doc a)
fontChange
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc a
begin forall a. Semigroup a => a -> a -> a
<> Doc a
d forall a. Semigroup a => a -> a -> a
<> Doc a
end