{- |
Export table data as OpenDocument Spreadsheet
<https://docs.oasis-open.org/office/OpenDocument/v1.3/>.
This format supports character encodings, fixed header rows and columns,
number formatting, text styles, merged cells, formulas, hyperlinks.
Currently we support Flat ODS, a plain uncompressed XML format.

This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>

-}
module Hledger.Write.Ods (
    printFods,
    ) where

import qualified Hledger.Write.Spreadsheet as Spr
import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))
import Hledger.Data.Types (CommoditySymbol, AmountPrecision(..))
import Hledger.Data.Types (acommodity, aquantity, astyle, asprecision)

import qualified Data.Text.Lazy as TL
import qualified Data.Text as T
import Data.Text (Text)

import qualified Data.Foldable as Fold
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Foldable (fold)
import Data.Map (Map)
import Data.Set (Set)
import Data.Maybe (catMaybes)

import qualified System.IO as IO
import Text.Printf (printf)


printFods ::
    IO.TextEncoding ->
    Map Text ((Maybe Int, Maybe Int), [[Cell Spr.NumLines Text]]) -> TL.Text
printFods encoding tables =
    let fileOpen customStyles =
          map (map (\c -> case c of '\'' -> '"'; _ -> c)) $
          printf "<?xml version='1.0' encoding='%s'?>" (show encoding) :
          "<office:document" :
          "  office:mimetype='application/vnd.oasis.opendocument.spreadsheet'" :
          "  office:version='1.3'" :
          "  xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance'" :
          "  xmlns:xsd='http://www.w3.org/2001/XMLSchema'" :
          "  xmlns:text='urn:oasis:names:tc:opendocument:xmlns:text:1.0'" :
          "  xmlns:style='urn:oasis:names:tc:opendocument:xmlns:style:1.0'" :
          "  xmlns:meta='urn:oasis:names:tc:opendocument:xmlns:meta:1.0'" :
          "  xmlns:config='urn:oasis:names:tc:opendocument:xmlns:config:1.0'" :
          "  xmlns:xlink='http://www.w3.org/1999/xlink'" :
          "  xmlns:fo='urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0'" :
          "  xmlns:ooo='http://openoffice.org/2004/office'" :
          "  xmlns:office='urn:oasis:names:tc:opendocument:xmlns:office:1.0'" :
          "  xmlns:table='urn:oasis:names:tc:opendocument:xmlns:table:1.0'" :
          "  xmlns:number='urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0'" :
          "  xmlns:of='urn:oasis:names:tc:opendocument:xmlns:of:1.2'" :
          "  xmlns:field='urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0'" :
          "  xmlns:form='urn:oasis:names:tc:opendocument:xmlns:form:1.0'>" :
          "<office:styles>" :
          "  <number:date-style style:name='iso-date'>" :
          "    <number:year number:style='long'/>" :
          "    <number:text>-</number:text>" :
          "    <number:month number:style='long'/>" :
          "    <number:text>-</number:text>" :
          "    <number:day number:style='long'/>" :
          "  </number:date-style>" :
          customStyles ++
          "</office:styles>" :
          []

        fileClose =
          "</office:document>" :
          []

        tableConfig tableNames =
          " <office:settings>" :
          "  <config:config-item-set config:name='ooo:view-settings'>" :
          "   <config:config-item-map-indexed config:name='Views'>" :
          "    <config:config-item-map-entry>" :
          "     <config:config-item-map-named config:name='Tables'>" :
          (fold $
           flip Map.mapWithKey tableNames $ \tableName (mTopRow,mLeftColumn) ->
             printf "      <config:config-item-map-entry config:name='%s'>" tableName :
             (flip foldMap mLeftColumn $ \leftColumn ->
                "       <config:config-item config:name='HorizontalSplitMode' config:type='short'>2</config:config-item>" :
                printf "       <config:config-item config:name='HorizontalSplitPosition' config:type='int'>%d</config:config-item>" leftColumn :
                printf "       <config:config-item config:name='PositionRight' config:type='int'>%d</config:config-item>" leftColumn :
                []) ++
             (flip foldMap mTopRow $ \topRow ->
                "       <config:config-item config:name='VerticalSplitMode' config:type='short'>2</config:config-item>" :
                printf "       <config:config-item config:name='VerticalSplitPosition' config:type='int'>%d</config:config-item>" topRow :
                printf "       <config:config-item config:name='PositionBottom' config:type='int'>%d</config:config-item>" topRow :
                []) ++
             "      </config:config-item-map-entry>" :
             []) ++
          "     </config:config-item-map-named>" :
          "    </config:config-item-map-entry>" :
          "   </config:config-item-map-indexed>" :
          "  </config:config-item-set>" :
          " </office:settings>" :
          []

        tableOpen name =
          "<office:body>" :
          "<office:spreadsheet>" :
          printf "<table:table table:name='%s'>" name :
          []

        tableClose =
          "</table:table>" :
          "</office:spreadsheet>" :
          "</office:body>" :
          []

    in  TL.unlines $ map (TL.fromStrict . T.pack) $
        fileOpen
          (let styles = cellStyles (foldMap (concat.snd) tables) in
           (numberConfig =<< Set.toList (foldMap (numberParams.snd) styles))
           ++
           (cellConfig =<< Set.toList styles)) ++
        tableConfig (fmap fst tables) ++
        (Map.toAscList tables >>= \(name,(_,table)) ->
            tableOpen name ++
            (table >>= \row ->
                "<table:table-row>" :
                (row >>= formatCell) ++
                "</table:table-row>" :
                []) ++
            tableClose) ++
        fileClose


dataStyleFromType :: Type -> DataStyle
dataStyleFromType typ =
    case typ of
        TypeString -> DataString
        TypeDate -> DataDate
        TypeAmount amt -> DataAmount (acommodity amt) (asprecision $ astyle amt)
        TypeMixedAmount -> DataMixedAmount

cellStyles ::
    (Ord border) =>
    [Cell border Text] ->
    Set ((Spr.Border border, Style), DataStyle)
cellStyles =
    Set.fromList .
    map (\cell ->
            ((cellBorder cell, cellStyle cell),
             dataStyleFromType $ cellType cell))

numberStyleName :: (CommoditySymbol, AmountPrecision) -> String
numberStyleName (comm, prec) =
    printf "%s-%s" comm $
    case prec of
        NaturalPrecision -> "natural"
        Precision k -> show k

numberParams :: DataStyle -> Set (CommoditySymbol, AmountPrecision)
numberParams (DataAmount comm prec) = Set.singleton (comm, prec)
numberParams _ = Set.empty

numberConfig :: (CommoditySymbol, AmountPrecision) -> [String]
numberConfig (comm, prec) =
    let precStr =
            case prec of
                NaturalPrecision -> ""
                Precision k -> printf " number:decimal-places='%d'" k
        name = numberStyleName (comm, prec)
    in
    printf "  <number:number-style style:name='number-%s'>" name :
    printf "    <number:number number:min-integer-digits='1'%s/>" precStr :
    printf "    <number:text>%s%s</number:text>"
      (if T.null comm then "" else " ") comm :
    "  </number:number-style>" :
    []

emphasisName :: Emphasis -> String
emphasisName emph =
    case emph of
        Item -> "item"
        Total -> "total"

cellStyleName :: Style -> String
cellStyleName style =
    case style of
        Head -> "head"
        Body emph -> emphasisName emph

linesName :: Spr.NumLines -> Maybe String
linesName prop =
    case prop of
        Spr.NoLine -> Nothing
        Spr.SingleLine -> Just "single"
        Spr.DoubleLine -> Just "double"

linesStyle :: Spr.NumLines -> String
linesStyle prop =
    case prop of
        Spr.NoLine -> "none"
        Spr.SingleLine -> "1.5pt solid #000000"
        Spr.DoubleLine -> "1.5pt double-thin #000000"

borderLabels :: Spr.Border String
borderLabels = Spr.Border "left" "right" "top" "bottom"

borderName :: Spr.Border Spr.NumLines -> String
borderName border =
    (\bs ->
        case bs of
            [] -> "noborder"
            _ ->
                ("border="++) $ List.intercalate "," $
                map (\(name,num) -> name ++ ':' : num) bs) $
    catMaybes $ Fold.toList $
    liftA2
        (\name numLines -> (,) name <$> linesName numLines)
        borderLabels
        border

borderStyle :: Spr.Border Spr.NumLines -> [String]
borderStyle border =
    if border == Spr.noBorder
        then []
        else (:[]) $
            printf "    <style:table-cell-properties%s/>" $
            (id :: String -> String) $ fold $
            liftA2 (printf " fo:border-%s='%s'") borderLabels $
            fmap linesStyle border

data DataStyle =
      DataString
    | DataDate
    | DataAmount CommoditySymbol AmountPrecision
    | DataMixedAmount
    deriving (Eq, Ord, Show)

cellConfig :: ((Spr.Border Spr.NumLines, Style), DataStyle) -> [String]
cellConfig ((border, cstyle), dataStyle) =
    let moreStyles =
            borderStyle border
            ++
            (
            case cstyle of
                Body Item -> []
                Body Total ->
                    ["    <style:text-properties fo:font-weight='bold'/>"]
                Head ->
                    "    <style:paragraph-properties fo:text-align='center'/>" :
                    "    <style:text-properties fo:font-weight='bold'/>" :
                    []
            )
            ++
            (
            case dataStyle of
                DataMixedAmount ->
                    ["    <style:paragraph-properties fo:text-align='end'/>"]
                _ -> []
            )
        cstyleName = cellStyleName cstyle
        bordName = borderName border
        style :: String
        style =
            case dataStyle of
                DataDate ->
                    printf
                      "style:name='%s-%s-date' style:data-style-name='iso-date'"
                      cstyleName bordName
                DataAmount comm prec ->
                    let name = numberStyleName (comm, prec) in
                    printf
                      "style:name='%s-%s-%s' style:data-style-name='number-%s'"
                      cstyleName bordName name name
                _ -> printf "style:name='%s-%s'" cstyleName bordName
    in
    case moreStyles of
        [] ->
            printf "  <style:style style:family='table-cell' %s/>" style :
            []
        _ ->
            printf "  <style:style style:family='table-cell' %s>" style :
            moreStyles ++
            "  </style:style>" :
            []


formatCell :: Cell Spr.NumLines Text -> [String]
formatCell cell =
    let style, valueType :: String
        style = tableStyle styleName
        cstyleName = cellStyleName $ cellStyle cell
        bordName = borderName $ cellBorder cell
        styleName :: String
        styleName =
            case dataStyleFromType $ cellType cell of
                DataDate -> printf "%s-%s-date" cstyleName bordName
                DataAmount comm prec ->
                    let name = numberStyleName (comm, prec) in
                    printf "%s-%s-%s" cstyleName bordName name
                _ -> printf "%s-%s" cstyleName bordName
        tableStyle = printf " table:style-name='%s'"

        valueType =
            case cellType cell of
                TypeAmount amt ->
                    printf
                        "office:value-type='float' office:value='%s'"
                        (show $ aquantity amt)
                TypeDate ->
                    printf
                        "office:value-type='date' office:date-value='%s'"
                        (cellContent cell)
                _ -> "office:value-type='string'"

    in
    printf "<table:table-cell%s %s>" style valueType :
    printf "<text:p>%s</text:p>" (escape $ T.unpack $ cellContent cell) :
    "</table:table-cell>" :
    []

escape :: String -> String
escape =
    concatMap $ \c ->
        case c of
            '\n' -> "&#10;"
            '&' -> "&amp;"
            '<' -> "&lt;"
            '>' -> "&gt;"
            '"' -> "&quot;"
            '\'' -> "&apos;"
            _ -> [c]