{-# 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 { stHasInlineMath :: Bool
                               , stFirstPara     :: Bool
                               , stNotes         :: [Note]
                               , stSmallCaps     :: Bool
                               , stHighlighting  :: Bool
                               , stInHeader      :: Bool
                               , stFontFeatures  :: Map.Map Char Bool
                               , stHasTables     :: Bool
                               }

defaultWriterState :: WriterState
defaultWriterState = WriterState{ stHasInlineMath = False
                                , stFirstPara     = True
                                , stNotes         = []
                                , stSmallCaps     = False
                                , stHighlighting  = False
                                , stInHeader      = False
                                , stFontFeatures  = Map.fromList [
                                                       ('I',False)
                                                     , ('B',False)
                                                     , ('C',False)
                                                     ]
                                , stHasTables     = False
                                }

type Note = [Block]

type MS = StateT WriterState

data EscapeMode = AllowUTF8        -- ^ use preferred man escapes
                | AsciiOnly        -- ^ escape everything
                deriving Show

combiningAccentsMap :: Map.Map Char Text
combiningAccentsMap = Map.fromList combiningAccents

essentialEscapes :: Map.Map Char Text
essentialEscapes = Map.fromList standardEscapes

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

characterCodeMap :: Map.Map Char Text
characterCodeMap = Map.fromList characterCodes

fontChange :: (HasChars a, IsString a, PandocMonad m) => MS m (Doc a)
fontChange = do
  features <- gets stFontFeatures
  inHeader <- gets stInHeader
  let filling = ['C' | fromMaybe False $ Map.lookup 'C' features] ++
                ['B' | inHeader ||
                       fromMaybe False (Map.lookup 'B' features)] ++
                ['I' | fromMaybe False $ Map.lookup 'I' features]
  return $
    if null filling
       then text "\\f[R]"
       else text $ "\\f[" ++ filling ++ "]"

withFontFeature :: (HasChars a, IsString a, PandocMonad m)
                => Char -> MS m (Doc a) -> MS m (Doc a)
withFontFeature c action = do
  modify $ \st -> st{ stFontFeatures = Map.adjust not c $ stFontFeatures st }
  begin <- fontChange
  d <- action
  modify $ \st -> st{ stFontFeatures = Map.adjust not c $ stFontFeatures st }
  end <- fontChange
  return $ begin <> d <> end