{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.Roff
   Copyright   : Copyright (C) 2007-2020 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 :: Bool
-> Bool
-> [Note]
-> Bool
-> Bool
-> Bool
-> Map Char Bool
-> Bool
-> WriterState
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  = [(Char, Bool)] -> Map Char Bool
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
                                                       (Char
'I',Bool
False)
                                                     , (Char
'B',Bool
False)
                                                     , (Char
'C',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
(Int -> EscapeMode -> ShowS)
-> (EscapeMode -> String)
-> ([EscapeMode] -> ShowS)
-> Show EscapeMode
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 = [(Char, Text)] -> Map Char Text
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 = [(Char, Text)] -> Map Char Text
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 ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EscapeMode -> String -> [Text]
escapeString' EscapeMode
e (String -> [Text]) -> (Text -> String) -> Text -> [Text]
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\\&." Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: EscapeMode -> String -> [Text]
escapeString' EscapeMode
escapeMode String
xs
    escapeString' EscapeMode
escapeMode (Char
x:String
xs) =
      case Char -> Map Char Text -> Maybe Text
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 Text -> [Text] -> [Text]
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 Text -> [Text] -> [Text]
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 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: EscapeMode -> String -> [Text]
escapeString' EscapeMode
escapeMode String
xs
                EscapeMode
AsciiOnly ->
                  let accents :: [Text]
accents = [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Text]) -> [Maybe Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Maybe Text -> Bool) -> [Maybe Text] -> [Maybe Text]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust
                        ((Char -> Maybe Text) -> String -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> Char -> Map Char Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
c Map Char Text
combiningAccentsMap) String
xs)
                      rest :: String
rest = Int -> ShowS
forall a. Int -> [a] -> [a]
drop ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
accents) String
xs
                      s :: Text
s = case Char -> Map Char Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
x Map Char Text
characterCodeMap of
                            Just Text
t  -> Text
"\\[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords (Text
tText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
accents) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
                            Maybe Text
Nothing -> Text
"\\[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords
                              (String -> Text
Text.pack (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"u%04X" (Char -> Int
ord Char
x)) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
accents) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
                  in  Text
s Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: EscapeMode -> String -> [Text]
escapeString' EscapeMode
escapeMode String
rest

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

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