    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-
    Copyright (C) 2013-2018 John MacFarlane <jgm@berkeley.edu>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
    -}

    {- |
       Module      : Text.Pandoc.Writers.Shared
       Copyright   : Copyright (C) 2013-2018 John MacFarlane
       License     : GNU GPL, version 2 or above

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

    Shared utility functions for pandoc writers.
    -}
    module Text.Pandoc.Writers.Shared (
                           metaToJSON
                         , metaToJSON'
                         , addVariablesToJSON
                         , getField
                         , setField
                         , resetField
                         , defField
                         , tagWithAttrs
                         , isDisplayMath
                         , fixDisplayMath
                         , unsmartify
                         , gridTable
                         , lookupMetaBool
                         , lookupMetaBlocks
                         , lookupMetaInlines
                         , lookupMetaString
                         , stripLeadingTrailingSpace
                         , toSubscript
                         , toSuperscript
                         )
    where
    import Prelude
    import Control.Monad (zipWithM)
    import Data.Aeson (FromJSON (..), Result (..), ToJSON (..), Value (Object),
                       encode, fromJSON)
    import Data.Char (chr, ord, isSpace)
    import qualified Data.HashMap.Strict as H
    import Data.List (groupBy, intersperse, transpose)
    import qualified Data.Map as M
    import Data.Maybe (isJust)
    import qualified Data.Text as T
    import qualified Data.Traversable as Traversable
    import qualified Text.Pandoc.Builder as Builder
    import Text.Pandoc.Definition
    import Text.Pandoc.Options
    import Text.Pandoc.Pretty
    import Text.Pandoc.Shared (stringify)
    import Text.Pandoc.UTF8 (toStringLazy)
    import Text.Pandoc.XML (escapeStringForXML)

    -- | Create JSON value for template from a 'Meta' and an association list
    -- of variables, specified at the command line or in the writer.
    -- Variables overwrite metadata fields with the same names.
    -- If multiple variables are set with the same name, a list is
    -- assigned.  Does nothing if 'writerTemplate' is Nothing.
    metaToJSON :: (Functor m, Monad m, ToJSON a)
               => WriterOptions
               -> ([Block] -> m a)
               -> ([Inline] -> m a)
               -> Meta
               -> m Value
    metaToJSON opts blockWriter inlineWriter meta
      | isJust (writerTemplate opts) =
        addVariablesToJSON opts <$> metaToJSON' blockWriter inlineWriter meta
      | otherwise = return (Object H.empty)

    -- | Like 'metaToJSON', but does not include variables and is
    -- not sensitive to 'writerTemplate'.
    metaToJSON' :: (Functor m, Monad m, ToJSON a)
               => ([Block] -> m a)
               -> ([Inline] -> m a)
               -> Meta
               -> m Value
    metaToJSON' blockWriter inlineWriter (Meta metamap) = do
      renderedMap <- Traversable.mapM
                     (metaValueToJSON blockWriter inlineWriter)
                     metamap
      return $ M.foldrWithKey defField (Object H.empty) renderedMap

    -- | Add variables to JSON object, replacing any existing values.
    -- Also include @meta-json@, a field containing a string representation
    -- of the original JSON object itself, prior to addition of variables.
    addVariablesToJSON :: WriterOptions -> Value -> Value
    addVariablesToJSON opts metadata =
      foldl (\acc (x,y) -> setField x y acc)
           (defField "meta-json" (toStringLazy $ encode metadata) (Object mempty))
           (writerVariables opts)
        `combineMetadata` metadata
      where combineMetadata (Object o1) (Object o2) = Object $ H.union o1 o2
            combineMetadata x _                     = x

    metaValueToJSON :: (Functor m, Monad m, ToJSON a)
                    => ([Block] -> m a)
                    -> ([Inline] -> m a)
                    -> MetaValue
                    -> m Value
    metaValueToJSON blockWriter inlineWriter (MetaMap metamap) = toJSON <$>
      Traversable.mapM (metaValueToJSON blockWriter inlineWriter) metamap
    metaValueToJSON blockWriter inlineWriter (MetaList xs) = toJSON <$>
      Traversable.mapM (metaValueToJSON blockWriter inlineWriter) xs
    metaValueToJSON _ _ (MetaBool b) = return $ toJSON b
    metaValueToJSON _ inlineWriter (MetaString s) = toJSON <$>
      inlineWriter (Builder.toList (Builder.text s))
    metaValueToJSON blockWriter _ (MetaBlocks bs) = toJSON <$> blockWriter bs
    metaValueToJSON _ inlineWriter (MetaInlines is) = toJSON <$> inlineWriter is

    -- | Retrieve a field value from a JSON object.
    getField :: FromJSON a
             => String
             -> Value
             -> Maybe a
    getField field (Object hashmap) = do
      result <- H.lookup (T.pack field) hashmap
      case fromJSON result of
           Success x -> return x
           _         -> fail "Could not convert from JSON"
    getField _ _ = fail "Not a JSON object"

    setField :: ToJSON a
             => String
             -> a
             -> Value
             -> Value
    -- | Set a field of a JSON object.  If the field already has a value,
    -- convert it into a list with the new value appended to the old value(s).
    -- This is a utility function to be used in preparing template contexts.
    setField field val (Object hashmap) =
      Object $ H.insertWith combine (T.pack field) (toJSON val) hashmap
      where combine newval oldval =
              case fromJSON oldval of
                    Success xs -> toJSON $ xs ++ [newval]
                    _          -> toJSON [oldval, newval]
    setField _ _  x = x

    resetField :: ToJSON a
               => String
               -> a
               -> Value
               -> Value
    -- | Reset a field of a JSON object.  If the field already has a value,
    -- the new value replaces it.
    -- This is a utility function to be used in preparing template contexts.
    resetField field val (Object hashmap) =
      Object $ H.insert (T.pack field) (toJSON val) hashmap
    resetField _ _  x = x

    defField :: ToJSON a
             => String
             -> a
             -> Value
             -> Value
    -- | Set a field of a JSON object if it currently has no value.
    -- If it has a value, do nothing.
    -- This is a utility function to be used in preparing template contexts.
    defField field val (Object hashmap) =
      Object $ H.insertWith f (T.pack field) (toJSON val) hashmap
        where f _newval oldval = oldval
    defField _ _  x = x

    -- Produce an HTML tag with the given pandoc attributes.
    tagWithAttrs :: String -> Attr -> Doc
    tagWithAttrs tag (ident,classes,kvs) = hsep
      ["<" <> text tag
      ,if null ident
          then empty
          else "id=" <> doubleQuotes (text ident)
      ,if null classes
          then empty
          else "class=" <> doubleQuotes (text (unwords classes))
      ,hsep (map (\(k,v) -> text k <> "=" <>
                    doubleQuotes (text (escapeStringForXML v))) kvs)
      ] <> ">"

    isDisplayMath :: Inline -> Bool
    isDisplayMath (Math DisplayMath _)          = True
    isDisplayMath (Span _ [Math DisplayMath _]) = True
    isDisplayMath _                             = False

    stripLeadingTrailingSpace :: [Inline] -> [Inline]
    stripLeadingTrailingSpace = go . reverse . go . reverse
      where go (Space:xs)     = xs
            go (SoftBreak:xs) = xs
            go xs             = xs

    -- Put display math in its own block (for ODT/DOCX).
    fixDisplayMath :: Block -> Block
    fixDisplayMath (Plain lst)
      | any isDisplayMath lst && not (all isDisplayMath lst) =
        -- chop into several paragraphs so each displaymath is its own
        Div ("",["math"],[]) $
           map Plain $
           filter (not . null) $
           map stripLeadingTrailingSpace $
           groupBy (\x y -> (isDisplayMath x && isDisplayMath y) ||
                             not (isDisplayMath x || isDisplayMath y)) lst
    fixDisplayMath (Para lst)
      | any isDisplayMath lst && not (all isDisplayMath lst) =
        -- chop into several paragraphs so each displaymath is its own
        Div ("",["math"],[]) $
           map Para $
           filter (not . null) $
           map stripLeadingTrailingSpace $
           groupBy (\x y -> (isDisplayMath x && isDisplayMath y) ||
                             not (isDisplayMath x || isDisplayMath y)) lst
    fixDisplayMath x = x

    unsmartify :: WriterOptions -> String -> String
    unsmartify opts ('\8217':xs) = '\'' : unsmartify opts xs
    unsmartify opts ('\8230':xs) = "..." ++ unsmartify opts xs
    unsmartify opts ('\8211':xs)
      | isEnabled Ext_old_dashes opts = '-' : unsmartify opts xs
      | otherwise                     = "--" ++ unsmartify opts xs
    unsmartify opts ('\8212':xs)
      | isEnabled Ext_old_dashes opts = "--" ++ unsmartify opts xs
      | otherwise                     = "---" ++ unsmartify opts xs
    unsmartify opts ('\8220':xs) = '"' : unsmartify opts xs
    unsmartify opts ('\8221':xs) = '"' : unsmartify opts xs
    unsmartify opts ('\8216':xs) = '\'' : unsmartify opts xs
    unsmartify opts (x:xs) = x : unsmartify opts xs
    unsmartify _ [] = []

    gridTable :: Monad m
              => WriterOptions
              -> (WriterOptions -> [Block] -> m Doc)
              -> Bool -- ^ headless
              -> [Alignment]
              -> [Double]
              -> [[Block]]
              -> [[[Block]]]
              -> m Doc
    gridTable opts blocksToDoc headless aligns widths headers rows = do
      -- the number of columns will be used in case of even widths
      let numcols = maximum (length aligns : length widths :
                               map length (headers:rows))
      -- handleGivenWidths wraps the given blocks in order for them to fit
      -- in cells with given widths. the returned content can be
      -- concatenated with borders and frames
      let handleGivenWidths widths' = do
            let widthsInChars' = map (
                          (\x -> if x < 1 then 1 else x) .
                          (\x -> x - 3) . floor .
                          (fromIntegral (writerColumns opts) *)
                          ) widths'
                -- replace page width (in columns) in the options with a
                -- given width if smaller (adjusting by two)
                useWidth w = opts{writerColumns = min (w - 2) (writerColumns opts)}
                -- prepare options to use with header and row cells
                columnOptions = map useWidth widthsInChars'
            rawHeaders' <- zipWithM blocksToDoc columnOptions headers
            rawRows' <- mapM
                 (\cs -> zipWithM blocksToDoc columnOptions cs)
                 rows
            return (widthsInChars', rawHeaders', rawRows')
      -- handleFullWidths tries to wrap cells to the page width or even
      -- more in cases where `--wrap=none`. thus the content here is left
      -- as wide as possible
      let handleFullWidths = do
            rawHeaders' <- mapM (blocksToDoc opts) headers
            rawRows' <- mapM (mapM (blocksToDoc opts)) rows
            let numChars [] = 0
                numChars xs = maximum . map offset $ xs
            let widthsInChars' =
                    map numChars $ transpose (rawHeaders' : rawRows')
            return (widthsInChars', rawHeaders', rawRows')
      -- handleZeroWidths calls handleFullWidths to check whether a wide
      -- table would fit in the page. if the produced table is too wide,
      -- it calculates even widths and passes the content to
      -- handleGivenWidths
      let handleZeroWidths = do
            (widthsInChars', rawHeaders', rawRows') <- handleFullWidths
            if sum widthsInChars' > writerColumns opts
               then -- use even widths
                    handleGivenWidths
                      (replicate numcols (1.0 / fromIntegral numcols) :: [Double])
               else return (widthsInChars', rawHeaders', rawRows')
      -- render the contents of header and row cells differently depending
      -- on command line options, widths given in this specific table, and
      -- cells' contents
      let handleWidths
            | writerWrapText opts == WrapNone  = handleFullWidths
            | all (== 0) widths                  = handleZeroWidths
            | otherwise                          = handleGivenWidths widths
      (widthsInChars, rawHeaders, rawRows) <- handleWidths
      let hpipeBlocks blocks = hcat [beg, middle, end]
            where h       = maximum (1 : map height blocks)
                  sep'    = lblock 3 $ vcat (replicate h (text " | "))
                  beg     = lblock 2 $ vcat (replicate h (text "| "))
                  end     = lblock 2 $ vcat (replicate h (text " |"))
                  middle  = chomp $ hcat $ intersperse sep' blocks
      let makeRow = hpipeBlocks . zipWith lblock widthsInChars
      let head' = makeRow rawHeaders
      let rows' = map (makeRow . map chomp) rawRows
      let borderpart ch align widthInChars =
               (if align == AlignLeft || align == AlignCenter
                   then char ':'
                   else char ch) <>
               text (replicate widthInChars ch) <>
               (if align == AlignRight || align == AlignCenter
                   then char ':'
                   else char ch)
      let border ch aligns' widthsInChars' =
            char '+' <>
            hcat (intersperse (char '+') (zipWith (borderpart ch)
                    aligns' widthsInChars')) <> char '+'
      let body = vcat $ intersperse (border '-' (repeat AlignDefault) widthsInChars)
                        rows'
      let head'' = if headless
                      then empty
                      else head' $$ border '=' aligns widthsInChars
      if headless
         then return $
               border '-' aligns widthsInChars $$
               body $$
               border '-' (repeat AlignDefault) widthsInChars
         else return $
               border '-' (repeat AlignDefault) widthsInChars $$
               head'' $$
               body $$
               border '-' (repeat AlignDefault) widthsInChars

    -- | Retrieve the metadata value for a given @key@
    -- and convert to Bool.
    lookupMetaBool :: String -> Meta -> Bool
    lookupMetaBool key meta =
      case lookupMeta key meta of
          Just (MetaBlocks _)     -> True
          Just (MetaInlines _)    -> True
          Just (MetaString (_:_)) -> True
          Just (MetaBool True)    -> True
          _                       -> False

    -- | Retrieve the metadata value for a given @key@
    -- and extract blocks.
    lookupMetaBlocks :: String -> Meta -> [Block]
    lookupMetaBlocks key meta =
      case lookupMeta key meta of
             Just (MetaBlocks bs)   -> bs
             Just (MetaInlines ils) -> [Plain ils]
             Just (MetaString s)    -> [Plain [Str s]]
             _                      -> []

    -- | Retrieve the metadata value for a given @key@
    -- and extract inlines.
    lookupMetaInlines :: String -> Meta -> [Inline]
    lookupMetaInlines key meta =
      case lookupMeta key meta of
             Just (MetaString s)           -> [Str s]
             Just (MetaInlines ils)        -> ils
             Just (MetaBlocks [Plain ils]) -> ils
             Just (MetaBlocks [Para ils])  -> ils
             _                             -> []

    -- | Retrieve the metadata value for a given @key@
    -- and convert to String.
    lookupMetaString :: String -> Meta -> String
    lookupMetaString key meta =
      case lookupMeta key meta of
             Just (MetaString s)    -> s
             Just (MetaInlines ils) -> stringify ils
             Just (MetaBlocks bs)   -> stringify bs
             Just (MetaBool b)      -> show b
             _                      -> ""

    toSuperscript :: Char -> Maybe Char
    toSuperscript '1' = Just '\x00B9'
    toSuperscript '2' = Just '\x00B2'
    toSuperscript '3' = Just '\x00B3'
    toSuperscript '+' = Just '\x207A'
    toSuperscript '-' = Just '\x207B'
    toSuperscript '=' = Just '\x207C'
    toSuperscript '(' = Just '\x207D'
    toSuperscript ')' = Just '\x207E'
    toSuperscript c
      | c >= '0' && c <= '9' =
                     Just $ chr (0x2070 + (ord c - 48))
      | isSpace c = Just c
      | otherwise = Nothing

    toSubscript :: Char -> Maybe Char
    toSubscript '+' = Just '\x208A'
    toSubscript '-' = Just '\x208B'
    toSubscript '=' = Just '\x208C'
    toSubscript '(' = Just '\x208D'
    toSubscript ')' = Just '\x208E'
    toSubscript c
      | c >= '0' && c <= '9' =
                     Just $ chr (0x2080 + (ord c - 48))
      | isSpace c = Just c
      | otherwise = Nothing