hledger-lib-1.41: Hledger/Write/Ods.hs
{- |
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 Prelude hiding (Applicative(..))
import Control.Monad (guard)
import Control.Applicative (Applicative(..))
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)
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)
printFods ::
IO.TextEncoding ->
Map Text ((Int, 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>" :
" <number:number-style style:name='integer'>" :
" <number:number number:min-integer-digits='1'/>" :
" </number:number-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 (topRow,leftColumn) ->
printf " <config:config-item-map-entry config:name='%s'>" tableName :
((guard (leftColumn>0) >>) $
" <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 :
[]) ++
((guard (topRow>0) >>) $
" <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
TypeInteger -> DataInteger
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
| DataInteger
| DataDate
| DataAmount CommoditySymbol AmountPrecision
| DataMixedAmount
deriving (Eq, Ord, Show)
cellConfig :: ((Spr.Border Spr.NumLines, Style), DataStyle) -> [String]
cellConfig ((border, cstyle), dataStyle) =
let boldStyle = " <style:text-properties fo:font-weight='bold'/>"
alignTop =
" <style:table-cell-properties style:vertical-align='top'/>"
alignParagraph =
printf " <style:paragraph-properties fo:text-align='%s'/>"
moreStyles =
borderStyle border
++
(
case cstyle of
Body Item ->
alignTop :
[]
Body Total ->
alignTop :
boldStyle :
[]
Head ->
alignParagraph "center" :
boldStyle :
[]
)
++
(
case dataStyle of
DataMixedAmount -> [alignParagraph "end"]
_ -> []
)
style :: String
style =
let (styleName,dataStyleName) = styleNames cstyle border dataStyle
in printf "style:name='%s'" styleName
++
foldMap (printf " style:data-style-name='%s'") dataStyleName
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 =
printf " table:style-name='%s'" $ fst $
styleNames
(cellStyle cell)
(cellBorder cell)
(dataStyleFromType $ cellType cell)
valueType =
case cellType cell of
TypeInteger ->
printf
"office:value-type='float' office:value='%s'"
(cellContent cell)
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'"
covered =
case cellSpan cell of
Spr.Covered -> "covered-"
_ -> ""
span_ =
case cellSpan cell of
Spr.SpanHorizontal n | n>1 ->
printf " table:number-columns-spanned='%d'" n
Spr.SpanVertical n | n>1 ->
printf " table:number-rows-spanned='%d'" n
_ -> ""
anchor text =
if T.null $ Spr.cellAnchor cell
then text
else printf "<text:a xlink:href='%s'>%s</text:a>"
(escape $ T.unpack $ Spr.cellAnchor cell) text
in
printf "<table:%stable-cell%s%s %s>" covered style span_ valueType :
printf "<text:p>%s</text:p>"
(anchor $ escape $ T.unpack $ cellContent cell) :
printf "</table:%stable-cell>" covered :
[]
styleNames ::
Style -> Spr.Border Spr.NumLines -> DataStyle -> (String, Maybe String)
styleNames cstyle border dataStyle =
let cstyleName = cellStyleName cstyle in
let bordName = borderName border in
case dataStyle of
DataDate ->
(printf "%s-%s-date" cstyleName bordName, Just "iso-date")
DataInteger ->
(printf "%s-%s-integer" cstyleName bordName, Just "integer")
DataAmount comm prec ->
let name = numberStyleName (comm, prec) in
(printf "%s-%s-%s" cstyleName bordName name,
Just $ printf "number-%s" name)
DataMixedAmount ->
(printf "%s-%s-mixedamount" cstyleName bordName, Nothing)
DataString -> (printf "%s-%s" cstyleName bordName, Nothing)
escape :: String -> String
escape =
concatMap $ \c ->
case c of
'\n' -> " "
'&' -> "&"
'<' -> "<"
'>' -> ">"
'"' -> """
'\'' -> "'"
_ -> [c]