content: {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE OverloadedStrings   #-}
  {- |
     Module      : Text.Pandoc.Writers.ODT
     Copyright   : Copyright (C) 2008-2024 John MacFarlane
     License     : GNU GPL, version 2 or above
  
     Maintainer  : John MacFarlane <jgm@berkeley.edu>
     Stability   : alpha
     Portability : portable
  
  Conversion of 'Pandoc' documents to ODT.
  -}
  module Text.Pandoc.Writers.ODT ( writeODT ) where
  import Codec.Archive.Zip
  import Control.Monad.Except (catchError, throwError)
  import Control.Monad.State.Strict (StateT, evalStateT, gets, modify, lift)
  import Control.Monad (MonadPlus(mplus))
  import qualified Data.ByteString.Lazy as B
  import Data.Maybe (fromMaybe)
  import Data.Generics (everywhere', mkT)
  import Data.List (isPrefixOf)
  import qualified Data.Map as Map
  import qualified Data.Text as T
  import qualified Data.Text.Lazy as TL
  import Data.Time
  import System.FilePath (takeDirectory, takeExtension, (<.>), (</>), isAbsolute)
  import Text.Collate.Lang (Lang (..), renderLang)
  import Text.Pandoc.Class.PandocMonad (PandocMonad, report, toLang)
  import qualified Text.Pandoc.Class.PandocMonad as P
  import Text.Pandoc.Data (readDataFile)
  import Text.Pandoc.Definition
  import Text.Pandoc.Error (PandocError(..))
  import Text.Pandoc.ImageSize
  import Text.Pandoc.Logging
  import Text.Pandoc.MIME (extensionFromMimeType, getMimeType)
  import Text.Pandoc.Options (WrapOption (..), WriterOptions (..),
                              HighlightMethod(Skylighting))
  import Text.DocLayout
  import Text.Pandoc.Shared (stringify, tshow)
  import Text.Pandoc.Version (pandocVersionText)
  import Text.Pandoc.Writers.Shared (lookupMetaString, lookupMetaBlocks,
                                     fixDisplayMath, getLang,
                                     ensureValidXmlIdentifiers)
  import Text.Pandoc.UTF8 (fromStringLazy, fromTextLazy, toTextLazy)
  import Text.Pandoc.Walk
  import Text.Pandoc.Writers.OpenDocument (writeOpenDocument)
  import Text.Pandoc.XML
  import Text.Pandoc.XML.Light
  import Text.TeXMath
  import qualified Text.XML.Light as XL
  import Network.URI (parseRelativeReference, URI(uriPath), isURI)
  import Skylighting
  
  newtype ODTState = ODTState { stEntries :: [Entry]
                           }
  
  type O m = StateT ODTState m
  
  -- | Produce an ODT file from a Pandoc document.
  writeODT :: PandocMonad m
           => WriterOptions  -- ^ Writer options
           -> Pandoc         -- ^ Document to convert
           -> m B.ByteString
  writeODT  opts doc =
    let initState = ODTState{ stEntries = []
                            }
        doc' = fixInternalLinks . ensureValidXmlIdentifiers $ doc
    in
      evalStateT (pandocToODT opts doc') initState
  
  -- | ODT internal links are evaluated relative to an imaginary folder
  -- structure that mirrors the zip structure.  The result is that relative
  -- links in the document need to start with `..`.  See #3524.
  fixInternalLinks :: Pandoc -> Pandoc
  fixInternalLinks = walk go
   where
    go (Link attr ils (src,tit)) =
      Link attr ils (fixRel src,tit)
    go x = x
    fixRel uri =
      case parseRelativeReference (T.unpack uri) of
        Just u
          | not (null (uriPath u)) -> tshow $ u{ uriPath = "../" <> uriPath u }
        _ -> uri
  
  -- | Produce an ODT file from a Pandoc document.
  pandocToODT :: PandocMonad m
              => WriterOptions  -- ^ Writer options
              -> Pandoc         -- ^ Document to convert
              -> O m B.ByteString
  pandocToODT opts doc@(Pandoc meta _) = do
    let title = docTitle meta
    let authors = docAuthors meta
    utctime <- P.getTimestamp
    lang <- toLang (getLang opts meta)
    refArchive <-
         case writerReferenceDoc opts of
               Just f -> lift $ toArchive . B.fromStrict . fst <$>
                                  (P.fetchItem (T.pack f))
               Nothing -> lift $ toArchive . B.fromStrict <$>
                                  readDataFile "reference.odt"
    -- handle formulas and pictures
    -- picEntriesRef <- P.newIORef ([] :: [Entry])
    doc' <- walkM (transformPicMath opts) $ walk fixDisplayMath doc
    newContents <- lift $ writeOpenDocument opts{writerWrapText = WrapNone} doc'
    epochtime <- floor `fmap` lift P.getPOSIXTime
    let contentEntry = toEntry "content.xml" epochtime
                       $ fromTextLazy $ TL.fromStrict newContents
    picEntries <- gets stEntries
    let archive = foldr addEntryToArchive refArchive
                  $ contentEntry : picEntries
    -- construct META-INF/manifest.xml based on archive
    let toFileEntry fp = case getMimeType fp of
                          Nothing  -> empty
                          Just m   -> selfClosingTag "manifest:file-entry"
                                       [("manifest:media-type", m)
                                       ,("manifest:full-path", T.pack fp)
                                       ]
    let files = [ ent | ent <- filesInArchive archive,
                               not ("META-INF" `isPrefixOf` ent) ]
    let formulas = [ takeDirectory ent ++ "/" | ent <- filesInArchive archive,
                        "Formula-" `isPrefixOf` ent, takeExtension ent == ".xml" ]
    let manifestEntry = toEntry "META-INF/manifest.xml" epochtime
          $ fromStringLazy $ render Nothing
          $ text "<?xml version=\"1.0\" encoding=\"utf-8\"?>"
          $$
           inTags True "manifest:manifest"
              [("xmlns:manifest","urn:oasis:names:tc:opendocument:xmlns:manifest:1.0")
              ,("manifest:version","1.3")] ( selfClosingTag "manifest:file-entry"
                   [("manifest:media-type","application/vnd.oasis.opendocument.text")
                   ,("manifest:full-path","/")
                   ,("manifest:version", "1.3")]
                  $$ vcat ( map toFileEntry files )
                  $$ vcat ( map toFileEntry formulas )
                )
    let archive' = addEntryToArchive manifestEntry archive
    -- create meta.xml
    let userDefinedMetaFields = [k | k <- Map.keys (unMeta meta)
                                , k `notElem` ["title", "lang", "author"
                                             , "description", "subject", "keywords"]]
    let escapedText = text . T.unpack . escapeStringForXML
    let keywords = case lookupMeta "keywords" meta of
                        Just (MetaList xs) -> map stringify xs
                        _                  -> []
    let userDefinedMeta =
          map (\k -> inTags False "meta:user-defined"
                [ ("meta:name", escapeStringForXML k)
                ,("meta:value-type", "string")
                ] (escapedText $ lookupMetaString k meta)) userDefinedMetaFields
    let metaTag metafield = inTagsSimple metafield . escapedText
    let metaEntry = toEntry "meta.xml" epochtime
         $ fromStringLazy $ render Nothing
         $ text "<?xml version=\"1.0\" encoding=\"utf-8\"?>"
         $$
          inTags True "office:document-meta"
             [("xmlns:office","urn:oasis:names:tc:opendocument:xmlns:office:1.0")
             ,("xmlns:xlink","http://www.w3.org/1999/xlink")
             ,("xmlns:dc","http://purl.org/dc/elements/1.1/")
             ,("xmlns:meta","urn:oasis:names:tc:opendocument:xmlns:meta:1.0")
             ,("xmlns:ooo","http://openoffice.org/2004/office")
             ,("xmlns:grddl","http://www.w3.org/2003/g/data-view#")
             ,("office:version","1.3")] ( inTags True "office:meta" []
                   ( metaTag "meta:generator" ("Pandoc/" <> pandocVersionText)
                     $$
                     metaTag "dc:title" (stringify title)
                     $$
                     metaTag "dc:description"
                            (T.intercalate "\n" (map stringify $
                                           lookupMetaBlocks "description" meta))
                     $$
                     metaTag "dc:subject" (lookupMetaString "subject" meta)
                     $$
                     metaTag "meta:keyword" (T.intercalate ", " keywords)
                     $$
                     case lang of
                          Just l  -> metaTag "dc:language" (renderLang l)
                          Nothing -> empty
                     $$
                     (\d a -> metaTag "meta:initial-creator" a
                           $$ metaTag "dc:creator" a
                           $$ metaTag "meta:creation-date" d
                           $$ metaTag "dc:date" d
                     ) (T.pack $ formatTime defaultTimeLocale "%FT%XZ" utctime)
                       (T.intercalate "; " (map stringify authors))
                     $$
                     vcat userDefinedMeta
                   )
               )
    -- make sure mimetype is first
    let mimetypeEntry = toEntry "mimetype" epochtime
                        $ fromStringLazy "application/vnd.oasis.opendocument.text"
    archive'' <- updateStyle opts lang
                    $ addEntryToArchive mimetypeEntry
                    $ addEntryToArchive metaEntry archive'
    return $ fromArchive archive''
  
  updateStyle :: forall m . PandocMonad m
              => WriterOptions -> Maybe Lang -> Archive -> O m Archive
  updateStyle opts mbLang arch = do
    epochtime <- floor `fmap` lift P.getPOSIXTime
    let goEntry :: Entry -> O m Entry
        goEntry e
          | eRelativePath e == "styles.xml"
            = case parseXMLElement (toTextLazy (fromEntry e)) of
                Left msg -> throwError $ PandocXMLError "styles.xml" msg
                Right d -> return $
                  toEntry "styles.xml" epochtime
                  ( fromTextLazy
                  . TL.fromStrict
                  . showTopElement
                  . maybe id addLang mbLang
                  . transformElement (\qn -> qName qn == "styles" &&
                                        qPrefix qn == Just "office" )
                       (case writerHighlightMethod opts of
                          Skylighting style -> addHlStyles style
                          _ -> id)
                  $ d )
          | otherwise = pure e
    entries <- mapM goEntry (zEntries arch)
    return arch{ zEntries = entries }
  
  addHlStyles :: Style -> Element -> Element
  addHlStyles sty el =
    el{ elContent = filter (not . isHlStyle) (elContent el) ++
                  styleToOpenDocument sty }
   where
     isHlStyle (Elem e) = "Tok" `T.isSuffixOf` (qName (elName e))
     isHlStyle _ = False
  
  -- top-down search
  transformElement :: (QName -> Bool)
                   -> (Element -> Element)
                   -> Element
                   -> Element
  transformElement g f el
    | g (elName el)
      = f el
    | otherwise
      = el{ elContent = map go (elContent el) }
   where
     go (Elem e) = Elem (transformElement g f e)
     go x = x
  
  -- TODO FIXME avoid this generic traversal!
  addLang :: Lang -> Element -> Element
  addLang lang = everywhere' (mkT updateLangAttr)
      where updateLangAttr (Attr n@(QName "language" _ (Just "fo")) _)
                             = Attr n (langLanguage lang)
            updateLangAttr (Attr n@(QName "country" _ (Just "fo")) _)
                             = Attr n (fromMaybe "" $ langRegion lang)
            updateLangAttr x = x
  
  -- | transform both Image and Math elements
  transformPicMath :: PandocMonad m => WriterOptions ->Inline -> O m Inline
  transformPicMath opts (Image attr@(id', cls, _) lab (src,t)) = catchError
     (do (img, mbMimeType) <- P.fetchItem src
         (ptX, ptY) <- case imageSize opts img of
                         Right s  -> return $ sizeInPoints s
                         Left msg -> do
                           report $ CouldNotDetermineImageSize src msg
                           return (100, 100)
         let dims =
               case (getDim Width, getDim Height) of
                 (Just w, Just h)              -> [("width", tshow w), ("height", tshow h)]
                 (Just w@(Percent _), Nothing) -> [("rel-width", tshow w),("rel-height", "scale"),("width", tshow ptX <> "pt"),("height", tshow ptY <> "pt")]
                 (Nothing, Just h@(Percent _)) -> [("rel-width", "scale"),("rel-height", tshow h),("width", tshow ptX <> "pt"),("height", tshow ptY <> "pt")]
                 (Just w@(Inch i), Nothing)    -> [("width", tshow w), ("height", tshow (i / ratio) <> "in")]
                 (Nothing, Just h@(Inch i))    -> [("width", tshow (i * ratio) <> "in"), ("height", tshow h)]
                 _                             -> [("width", tshow ptX <> "pt"), ("height", tshow ptY <> "pt")]
               where
                 ratio = ptX / ptY
                 getDim dir = case dimension dir attr of
                                Just (Percent i) -> Just $ Percent i
                                Just dim         -> Just $ Inch $ inInch opts dim
                                Nothing          -> Nothing
         let  newattr = (id', cls, dims)
         src' <- if writerLinkImages opts
                    then
                      case T.unpack src of
                        s | isURI s -> return src
                          | isAbsolute s -> return src
                          | otherwise -> return $ T.pack $ ".." </> s
                    else do
                      entries <- gets stEntries
                      let extension = maybe (takeExtension $ takeWhile (/='?') $ T.unpack src) T.unpack
                                          (mbMimeType >>= extensionFromMimeType)
                      let newsrc = "Pictures/" ++ show (length entries) <.> extension
                      let toLazy = B.fromChunks . (:[])
                      epochtime <- floor `fmap` lift P.getPOSIXTime
                      let entry = toEntry newsrc epochtime $ toLazy img
                      modify $ \st -> st{ stEntries = entry : entries }
                      return $ T.pack newsrc
         return $ Image newattr lab (src', t))
     (\e -> do
         report $ CouldNotFetchResource src $ T.pack (show e)
         return $ Emph lab)
  
  transformPicMath _ (Math t math) = do
    entries <- gets stEntries
    let dt = if t == InlineMath then DisplayInline else DisplayBlock
    case writeMathML dt <$> readTeX math of
         Left  _ -> return $ Math t math
         Right r -> do
           let conf = XL.useShortEmptyTags (const False) XL.defaultConfigPP
           let mathml = XL.ppcTopElement conf r
           epochtime <- floor `fmap` lift P.getPOSIXTime
           let dirname = "Formula-" ++ show (length entries) ++ "/"
           let fname = dirname ++ "content.xml"
           let entry = toEntry fname epochtime (fromStringLazy mathml)
           let fname' = dirname ++ "settings.xml"
           let entry' = toEntry fname' epochtime $ documentSettings (t == InlineMath)
           modify $ \st -> st{ stEntries = entry' : (entry : entries) }
           return $ RawInline (Format "opendocument") $ render Nothing $
             inTags False "draw:frame" (if t == DisplayMath
                                        then [("draw:style-name","fr2")
                                             -- `draw:frame` does not support either
                                             -- `style:vertical-pos` or `style:vertical-rel`,
                                             -- therefore those attributes must go into the
                                             -- `style:style` element
                                             ,("text:anchor-type","paragraph")]
                                        else [("draw:style-name","fr1")
                                             ,("text:anchor-type","as-char")]) $
               selfClosingTag "draw:object" [("xlink:href", T.pack dirname)
                                          , ("xlink:type", "simple")
                                          , ("xlink:show", "embed")
                                          , ("xlink:actuate", "onLoad")]
  
  transformPicMath _ x = return x
  
  documentSettings :: Bool -> B.ByteString
  documentSettings isTextMode = fromStringLazy $ render Nothing
      $ text "<?xml version=\"1.0\" encoding=\"utf-8\"?>"
      $$
      inTags True "office:document-settings"
        [("xmlns:office","urn:oasis:names:tc:opendocument:xmlns:office:1.0")
        ,("xmlns:xlink","http://www.w3.org/1999/xlink")
        ,("xmlns:config","urn:oasis:names:tc:opendocument:xmlns:config:1.0")
        ,("xmlns:ooo","http://openoffice.org/2004/office")
        ,("office:version","1.3")] (
         inTagsSimple "office:settings" $
           inTags False "config:config-item-set"
             [("config:name", "ooo:configuration-settings")] $
             inTags False "config:config-item" [("config:name", "IsTextMode")
                                               ,("config:type", "boolean")] $
                                                text $ if isTextMode then "true" else "false")
  
  styleToOpenDocument :: Style -> [Content]
  styleToOpenDocument style = map (Elem . toStyle) alltoktypes
    where alltoktypes = enumFromTo KeywordTok NormalTok
          styleName x =
            case T.break (== ':') x of
              (b, a) | T.null a  -> QName x Nothing (Just "style")
                     | otherwise -> QName (T.drop 1 a) Nothing (Just b)
          styleAttr (x, y) = Attr (styleName x) y
          styleAttrs = map styleAttr
          styleElement x attrs cs =
            Element (styleName x) (styleAttrs attrs) cs Nothing
          toStyle toktype =
            styleElement "style"
              [("name", tshow toktype), ("family", "text")]
              [Elem (styleElement "text-properties"
                        (tokColor toktype ++ tokBgColor toktype ++
                          [("fo:font-style", "italic") |
                             tokFeature tokenItalic toktype ] ++
                          [("fo:font-weight", "bold") |
                             tokFeature tokenBold toktype ] ++
                          [("style:text-underline-style", "solid") |
                             tokFeature tokenUnderline toktype ])
                          [])]
          tokStyles = tokenStyles style
          tokFeature f toktype = maybe False f $ Map.lookup toktype tokStyles
          tokColor toktype =
            maybe [] (\c -> [("fo:color", T.pack (fromColor c))])
                          ((tokenColor =<< Map.lookup toktype tokStyles)
                             `mplus` defaultColor style)
          tokBgColor toktype =
            maybe [] (\c -> [("fo:background-color", T.pack (fromColor c))])
                      (tokenBackground =<< Map.lookup toktype tokStyles)
  