content: {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FlexibleContexts  #-}
  {-# LANGUAGE TypeFamilies      #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE OverloadedStrings #-}
  {- |
   Module : Text.Pandoc.Readers.Docx.Parse.Styles
   Copyright : Copyright (C) 2014-2020 Jesse Rosenthal
                             2019 Nikolay Yakimov <root@livid.pp.ru>
   License : GNU GPL, version 2 or above
  
   Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
   Stability : alpha
   Portability : portable
  
  Type machinery and code for extraction and manipulation of docx styles
  -}
  
  module Text.Pandoc.Readers.Docx.Parse.Styles (
      CharStyleId(..)
    , CharStyle
    , ParaStyleId(..)
    , ParStyle(..)
    , ParIndentation(..)
    , RunStyle(..)
    , HasStyleName
    , StyleName
    , ParaStyleName
    , CharStyleName
    , FromStyleName
    , VertAlign(..)
    , StyleId
    , HasStyleId
    , archiveToStyles'
    , getStyleId
    , getStyleName
    , cStyleData
    , fromStyleName
    , fromStyleId
    , stringToInteger
    , getIndentation
    , getNumInfo
    , elemToRunStyle
    , defaultRunStyle
    , checkOnOff
    ) where
  import Codec.Archive.Zip
  import Control.Applicative ((<|>))
  import Data.Function (on)
  import Data.String (IsString(..))
  import qualified Data.Map as M
  import qualified Data.Text as T
  import qualified Data.Text.Read
  import Data.Text (Text)
  import Data.Maybe
  import Data.Coerce
  import Text.Pandoc.Readers.Docx.Util
  import qualified Text.Pandoc.UTF8 as UTF8
  import Text.Pandoc.XML.Light
  
  newtype CharStyleId   = CharStyleId T.Text
    deriving (Show, Eq, Ord, IsString, FromStyleId)
  newtype ParaStyleId   = ParaStyleId T.Text
    deriving (Show, Eq, Ord, IsString, FromStyleId)
  
  newtype CharStyleName = CharStyleName CIString
    deriving (Show, Eq, Ord, IsString, FromStyleName)
  newtype ParaStyleName = ParaStyleName CIString
    deriving (Show, Eq, Ord, IsString, FromStyleName)
  
  -- Case-insensitive comparisons
  newtype CIString = CIString T.Text deriving (Show, IsString, FromStyleName)
  
  class FromStyleName a where
    fromStyleName :: a -> T.Text
  
  instance FromStyleName String where
    fromStyleName = T.pack
  
  instance FromStyleName T.Text where
    fromStyleName = id
  
  class FromStyleId a where
    fromStyleId :: a -> T.Text
  
  instance FromStyleId String where
    fromStyleId = T.pack
  
  instance FromStyleId T.Text where
    fromStyleId = id
  
  instance Eq CIString where
     (==) = (==) `on` T.toCaseFold . coerce
  
  instance Ord CIString where
    compare = compare `on` T.toCaseFold . coerce
  
  data VertAlign = BaseLn | SupScrpt | SubScrpt
                 deriving Show
  
  data CharStyle = CharStyle { cStyleId   :: CharStyleId
                             , cStyleName :: CharStyleName
                             , cStyleData :: RunStyle
                             } deriving (Show)
  
  data RunStyle = RunStyle { isBold       :: Maybe Bool
                           , isBoldCTL    :: Maybe Bool
                           , isItalic     :: Maybe Bool
                           , isItalicCTL  :: Maybe Bool
                           , isSmallCaps  :: Maybe Bool
                           , isStrike     :: Maybe Bool
                           , isRTL        :: Maybe Bool
                           , isForceCTL   :: Maybe Bool
                           , rHighlight   :: Maybe Text
                           , rVertAlign   :: Maybe VertAlign
                           , rUnderline   :: Maybe Text
                           , rParentStyle :: Maybe CharStyle
                           }
                  deriving Show
  
  data ParIndentation = ParIndentation { leftParIndent    :: Maybe Integer
                                       , rightParIndent   :: Maybe Integer
                                       , hangingParIndent :: Maybe Integer}
                        deriving Show
  
  data ParStyle = ParStyle { headingLev    :: Maybe (ParaStyleName, Int)
                           , indent        :: Maybe ParIndentation
                           , numInfo       :: Maybe (T.Text, T.Text)
                           , psParentStyle :: Maybe ParStyle
                           , pStyleName    :: ParaStyleName
                           , pStyleId      :: ParaStyleId
                           }
                      deriving Show
  
  defaultRunStyle :: RunStyle
  defaultRunStyle = RunStyle { isBold = Nothing
                             , isBoldCTL = Nothing
                             , isItalic = Nothing
                             , isItalicCTL = Nothing
                             , isSmallCaps = Nothing
                             , isStrike = Nothing
                             , isRTL = Nothing
                             , isForceCTL = Nothing
                             , rHighlight = Nothing
                             , rVertAlign = Nothing
                             , rUnderline = Nothing
                             , rParentStyle = Nothing
                             }
  
  archiveToStyles'
    :: (Ord k1, Ord k2, ElemToStyle a1, ElemToStyle a2)
    => (a1 -> k1) -> (a2 -> k2) -> Archive -> (M.Map k1 a1, M.Map k2 a2)
  archiveToStyles' conv1 conv2 zf =
    case findEntryByPath "word/styles.xml" zf of
      Nothing -> (M.empty, M.empty)
      Just entry ->
        case parseXMLElement . UTF8.toTextLazy . fromEntry $ entry of
          Left _ -> (M.empty, M.empty)
          Right styElem ->
            let namespaces = elemToNameSpaces styElem
            in
             ( M.fromList $ map (\r -> (conv1 r, r)) $
                 buildBasedOnList namespaces styElem Nothing,
               M.fromList $ map (\p -> (conv2 p, p)) $
                 buildBasedOnList namespaces styElem Nothing)
  
  isBasedOnStyle :: (ElemToStyle a, FromStyleId (StyleId a)) => NameSpaces -> Element -> Maybe a -> Bool
  isBasedOnStyle ns element parentStyle
    | isElem ns "w" "style" element
    , Just styleType <- findAttrByName ns "w" "type" element
    , styleType == cStyleType parentStyle
    , Just basedOnVal <- findChildByName ns "w" "basedOn" element >>=
                         findAttrByName ns "w" "val"
    , Just ps <- parentStyle = basedOnVal == fromStyleId (getStyleId ps)
    | isElem ns "w" "style" element
    , Just styleType <- findAttrByName ns "w" "type" element
    , styleType == cStyleType parentStyle
    , Nothing <- findChildByName ns "w" "basedOn" element
    , Nothing <- parentStyle = True
    | otherwise = False
  
  class HasStyleId a => ElemToStyle a where
    cStyleType  :: Maybe a -> Text
    elemToStyle :: NameSpaces -> Element -> Maybe a -> Maybe a
  
  class FromStyleId (StyleId a) => HasStyleId a where
    type StyleId a
    getStyleId :: a -> StyleId a
  
  class FromStyleName (StyleName a) => HasStyleName a where
    type StyleName a
    getStyleName :: a -> StyleName a
  
  instance ElemToStyle CharStyle where
    cStyleType _ = "character"
    elemToStyle ns element parentStyle
      | isElem ns "w" "style" element
      , Just "character" <- findAttrByName ns "w" "type" element =
        elemToCharStyle ns element parentStyle
      | otherwise = Nothing
  
  instance HasStyleId CharStyle where
    type StyleId CharStyle = CharStyleId
    getStyleId = cStyleId
  
  instance HasStyleName CharStyle where
    type StyleName CharStyle = CharStyleName
    getStyleName = cStyleName
  
  instance ElemToStyle ParStyle where
    cStyleType _ = "paragraph"
    elemToStyle ns element parentStyle
      | isElem ns "w" "style" element
      , Just "paragraph" <- findAttrByName ns "w" "type" element
      = elemToParStyleData ns element parentStyle
      | otherwise = Nothing
  
  instance HasStyleId ParStyle where
    type StyleId ParStyle = ParaStyleId
    getStyleId = pStyleId
  
  instance HasStyleName ParStyle where
    type StyleName ParStyle = ParaStyleName
    getStyleName = pStyleName
  
  getStyleChildren :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a]
  getStyleChildren ns element parentStyle
    | isElem ns "w" "styles" element =
      mapMaybe (\e -> elemToStyle ns e parentStyle) $
      filterChildren (\e' -> isBasedOnStyle ns e' parentStyle) element
    | otherwise = []
  
  buildBasedOnList :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a]
  buildBasedOnList ns element rootStyle =
    case getStyleChildren ns element rootStyle of
      [] -> []
      stys -> stys ++
              concatMap (buildBasedOnList ns element . Just) stys
  
  stringToInteger :: Text -> Maybe Integer
  stringToInteger s = case Data.Text.Read.decimal s of
                        Right (x,t) | T.null t -> Just x
                        _                      -> Nothing
  
  checkOnOff :: NameSpaces -> Element -> QName -> Maybe Bool
  checkOnOff ns rPr tag
    | Just t <-  findChild tag rPr
    , Just val <- findAttrByName ns "w" "val" t =
      Just $ case val of
        "true"  -> True
        "false" -> False
        "on"    -> True
        "off"   -> False
        "1"     -> True
        "0"     -> False
        _       -> False
    | Just _ <- findChild tag rPr = Just True
  checkOnOff _ _ _ = Nothing
  
  elemToCharStyle :: NameSpaces
                  -> Element -> Maybe CharStyle -> Maybe CharStyle
  elemToCharStyle ns element parentStyle
    = CharStyle <$> (CharStyleId <$> findAttrByName ns "w" "styleId" element)
                <*> getElementStyleName ns element
                <*> Just (elemToRunStyle ns element parentStyle)
  
  elemToRunStyle :: NameSpaces -> Element -> Maybe CharStyle -> RunStyle
  elemToRunStyle ns element parentStyle
    | Just rPr <- findChildByName ns "w" "rPr" element =
      RunStyle
        {
          isBold = checkOnOff ns rPr (elemName ns "w" "b")
        , isBoldCTL = checkOnOff ns rPr (elemName ns "w" "bCs")
        , isItalic = checkOnOff ns rPr (elemName ns "w" "i")
        , isItalicCTL = checkOnOff ns rPr (elemName ns "w" "iCs")
        , isSmallCaps = checkOnOff ns rPr (elemName ns "w" "smallCaps")
        , isStrike = checkOnOff ns rPr (elemName ns "w" "strike")
        , isRTL = checkOnOff ns rPr (elemName ns "w" "rtl")
        , isForceCTL = checkOnOff ns rPr (elemName ns "w" "cs")
        , rHighlight =
            findChildByName ns "w" "highlight" rPr >>=
              findAttrByName ns "w" "val"
        , rVertAlign =
             findChildByName ns "w" "vertAlign" rPr >>=
             findAttrByName ns "w" "val" >>=
             \v -> Just $ case v of
               "superscript" -> SupScrpt
               "subscript"   -> SubScrpt
               _             -> BaseLn
        , rUnderline =
            findChildByName ns "w" "u" rPr >>=
            findAttrByName ns "w" "val"
        , rParentStyle = parentStyle
        }
  elemToRunStyle _ _ _ = defaultRunStyle
  
  getHeaderLevel :: NameSpaces -> Element -> Maybe (ParaStyleName, Int)
  getHeaderLevel ns element
    | Just styleName <- getElementStyleName ns element
    , Just n <- stringToInteger =<<
                (T.stripPrefix "heading " . T.toLower $
                  fromStyleName styleName)
    , n > 0 = Just (styleName, fromInteger n)
  getHeaderLevel _ _ = Nothing
  
  getIndentation :: NameSpaces -> Element -> Maybe ParIndentation
  getIndentation ns el = do
    indElement <- findChildByName ns "w" "pPr" el >>=
                  findChildByName ns "w" "ind"
    return $ ParIndentation
      {
        leftParIndent = findAttrByName ns "w" "left" indElement <|>
                        findAttrByName ns "w" "start" indElement >>=
                        stringToInteger
      , rightParIndent = findAttrByName ns "w" "right" indElement <|>
                         findAttrByName ns "w" "end" indElement >>=
                         stringToInteger
      , hangingParIndent = findAttrByName ns "w" "hanging" indElement >>=
                           stringToInteger
      }
  
  getElementStyleName :: Coercible T.Text a => NameSpaces -> Element -> Maybe a
  getElementStyleName ns el = coerce <$>
    ((findChildByName ns "w" "name" el >>= findAttrByName ns "w" "val")
    <|> findAttrByName ns "w" "styleId" el)
  
  getNumInfo :: NameSpaces -> Element -> Maybe (T.Text, T.Text)
  getNumInfo ns element = do
    let numPr = findChildByName ns "w" "pPr" element >>=
                findChildByName ns "w" "numPr"
        lvl = fromMaybe "0" (numPr >>=
                             findChildByName ns "w" "ilvl" >>=
                             findAttrByName ns "w" "val")
    numId <- numPr >>=
             findChildByName ns "w" "numId" >>=
             findAttrByName ns "w" "val"
    return (numId, lvl)
  
  elemToParStyleData :: NameSpaces -> Element -> Maybe ParStyle -> Maybe ParStyle
  elemToParStyleData ns element parentStyle
    | Just styleId <- findAttrByName ns "w" "styleId" element
    , Just styleName <- getElementStyleName ns element
    = Just $ ParStyle
        {
          headingLev = getHeaderLevel ns element
        , indent = getIndentation ns element
        , numInfo = getNumInfo ns element
        , psParentStyle = parentStyle
        , pStyleName = styleName
        , pStyleId = ParaStyleId styleId
        }
  elemToParStyleData _ _ _ = Nothing
  