diff --git a/hledger-lib/Hledger/Write/Html.hs b/hledger-lib/Hledger/Write/Html.hs index b748876cb..fba93f362 100644 --- a/hledger-lib/Hledger/Write/Html.hs +++ b/hledger-lib/Hledger/Write/Html.hs @@ -8,24 +8,43 @@ module Hledger.Write.Html ( printHtml, ) where +import qualified Hledger.Write.Spreadsheet as Spr import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..)) +import qualified Data.Text as Text import qualified Lucid.Base as LucidBase import qualified Lucid +import Data.Text (Text) import Data.Foldable (for_) -printHtml :: [[Cell (Lucid.Html ())]] -> Lucid.Html () -printHtml table = +printHtml :: (Lines border) => [[Cell border (Lucid.Html ())]] -> Lucid.Html () +printHtml table = do + Lucid.style_ $ Text.unlines $ + "" : + "table {border-collapse:collapse}" : + "th, td {padding-left:1em}" : + "th.account, td.account {padding-left:0;}" : + [] Lucid.table_ $ for_ table $ \row -> - Lucid.tr_ $ for_ row $ \cell -> - formatCell cell + Lucid.tr_ $ for_ row $ \cell -> + formatCell cell -formatCell :: Cell (Lucid.Html ()) -> Lucid.Html () +formatCell :: (Lines border) => Cell border (Lucid.Html ()) -> Lucid.Html () formatCell cell = let str = cellContent cell in + let border field access = + map (field<>) $ borderLines $ access $ cellBorder cell in + let leftBorder = border "border-left:" Spr.borderLeft in + let rightBorder = border "border-right:" Spr.borderRight in + let topBorder = border "border-top:" Spr.borderTop in + let bottomBorder = border "border-bottom:" Spr.borderBottom in + let style = + case leftBorder++rightBorder++topBorder++bottomBorder of + [] -> [] + ss -> [Lucid.style_ $ Text.intercalate "; " ss] in case cellStyle cell of - Head -> Lucid.th_ str + Head -> Lucid.th_ style str Body emph -> let align = case cellType cell of @@ -36,4 +55,18 @@ formatCell cell = case emph of Item -> id Total -> Lucid.b_ - in Lucid.td_ align $ withEmph str + in Lucid.td_ (style++align) $ withEmph str + + +class (Spr.Lines border) => Lines border where + borderLines :: border -> [Text] + +instance Lines () where + borderLines () = [] + +instance Lines Spr.NumLines where + borderLines prop = + case prop of + Spr.NoLine -> [] + Spr.SingleLine -> ["black"] + Spr.DoubleLine -> ["double black"] diff --git a/hledger-lib/Hledger/Write/Ods.hs b/hledger-lib/Hledger/Write/Ods.hs index cdeb014f6..12887e1f5 100644 --- a/hledger-lib/Hledger/Write/Ods.hs +++ b/hledger-lib/Hledger/Write/Ods.hs @@ -12,6 +12,7 @@ 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) @@ -20,12 +21,14 @@ 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 (mapMaybe) +import Data.Maybe (catMaybes) import qualified System.IO as IO import Text.Printf (printf) @@ -33,7 +36,7 @@ import Text.Printf (printf) printFods :: IO.TextEncoding -> - Map Text ((Maybe Int, Maybe Int), [[Cell Text]]) -> TL.Text + 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)) $ @@ -57,20 +60,6 @@ printFods encoding tables = " xmlns:field='urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0'" : " xmlns:form='urn:oasis:names:tc:opendocument:xmlns:form:1.0'>" : "" : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : " " : " " : " -" : @@ -78,12 +67,6 @@ printFods encoding tables = " -" : " " : " " : - " " : - " " : - " " : - " " : customStyles ++ "" : [] @@ -135,7 +118,7 @@ printFods encoding tables = in TL.unlines $ map (TL.fromStrict . T.pack) $ fileOpen (let styles = cellStyles (foldMap (concat.snd) tables) in - (numberConfig =<< Set.toList (Set.map snd styles)) + (numberConfig =<< Set.toList (foldMap (numberParams.snd) styles)) ++ (cellConfig =<< Set.toList styles)) ++ tableConfig (fmap fst tables) ++ @@ -150,18 +133,23 @@ printFods encoding tables = fileClose -cellStyles :: [Cell Text] -> Set (Emphasis, (CommoditySymbol, AmountPrecision)) +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 . - mapMaybe (\cell -> - case cellType cell of - TypeAmount amt -> - Just - (case cellStyle cell of - Body emph -> emph - Head -> Total, - (acommodity amt, asprecision $ astyle amt)) - _ -> Nothing) + map (\cell -> + ((cellBorder cell, cellStyle cell), + dataStyleFromType $ cellType cell)) numberStyleName :: (CommoditySymbol, AmountPrecision) -> String numberStyleName (comm, prec) = @@ -170,6 +158,10 @@ numberStyleName (comm, prec) = 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 = @@ -191,41 +183,123 @@ emphasisName emph = Item -> "item" Total -> "total" -cellConfig :: (Emphasis, (CommoditySymbol, AmountPrecision)) -> [String] -cellConfig (emph, numParam) = - let name = numberStyleName numParam in - let style :: String +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 " " $ + (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 -> + [" "] + Head -> + " " : + " " : + [] + ) + ++ + ( + case dataStyle of + DataMixedAmount -> + [" "] + _ -> [] + ) + cstyleName = cellStyleName cstyle + bordName = borderName border + style :: String style = - printf "style:name='%s-%s' style:data-style-name='number-%s'" - (emphasisName emph) name name in - case emph of - Item -> + 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 : [] - Total -> + _ -> printf " " style : - " " : + moreStyles ++ " " : [] -formatCell :: Cell Text -> [String] +formatCell :: Cell Spr.NumLines Text -> [String] formatCell cell = let style, valueType :: String - style = - case (cellStyle cell, cellType cell) of - (Body emph, TypeAmount amt) -> tableStyle $ numberStyle emph amt - (Body Item, TypeString) -> "" - (Body Item, TypeMixedAmount) -> tableStyle "amount" - (Body Item, TypeDate) -> tableStyle "date" - (Body Total, TypeString) -> tableStyle "foot" - (Body Total, TypeMixedAmount) -> tableStyle "total-amount" - (Body Total, TypeDate) -> tableStyle "foot-date" - (Head, _) -> tableStyle "head" - numberStyle emph amt = - printf "%s-%s" - (emphasisName emph) - (numberStyleName (acommodity amt, asprecision $ astyle amt)) + 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 = diff --git a/hledger-lib/Hledger/Write/Spreadsheet.hs b/hledger-lib/Hledger/Write/Spreadsheet.hs index 96fb14610..8da63fddd 100644 --- a/hledger-lib/Hledger/Write/Spreadsheet.hs +++ b/hledger-lib/Hledger/Write/Spreadsheet.hs @@ -7,6 +7,10 @@ module Hledger.Write.Spreadsheet ( Style(..), Emphasis(..), Cell(..), + Border(..), + Lines(..), + NumLines(..), + noBorder, defaultCell, emptyCell, ) where @@ -27,23 +31,62 @@ data Style = Body Emphasis | Head data Emphasis = Item | Total deriving (Eq, Ord, Show) -data Cell text = + +class Lines border where noLine :: border +instance Lines () where noLine = () +instance Lines NumLines where noLine = NoLine + +{- | +The same as Tab.Properties, but has 'Eq' and 'Ord' instances. +We need those for storing 'NumLines' in 'Set's. +-} +data NumLines = NoLine | SingleLine | DoubleLine + deriving (Eq, Ord, Show) + +data Border lines = + Border { + borderLeft, borderRight, + borderTop, borderBottom :: lines + } + deriving (Eq, Ord, Show) + +instance Functor Border where + fmap f (Border left right top bottom) = + Border (f left) (f right) (f top) (f bottom) + +instance Applicative Border where + pure a = Border a a a a + Border fLeft fRight fTop fBottom <*> Border left right top bottom = + Border (fLeft left) (fRight right) (fTop top) (fBottom bottom) + +instance Foldable Border where + foldMap f (Border left right top bottom) = + f left <> f right <> f top <> f bottom + +noBorder :: (Lines border) => Border border +noBorder = pure noLine + + +data Cell border text = Cell { cellType :: Type, + cellBorder :: Border border, cellStyle :: Style, cellContent :: text } -instance Functor Cell where - fmap f (Cell typ style content) = Cell typ style $ f content +instance Functor (Cell border) where + fmap f (Cell typ border style content) = + Cell typ border style $ f content -defaultCell :: text -> Cell text +defaultCell :: (Lines border) => text -> Cell border text defaultCell text = Cell { cellType = TypeString, + cellBorder = noBorder, cellStyle = Body Item, cellContent = text } -emptyCell :: (Monoid text) => Cell text +emptyCell :: (Lines border, Monoid text) => Cell border text emptyCell = defaultCell mempty diff --git a/hledger/Hledger/Cli/Commands/Balance.hs b/hledger/Hledger/Cli/Commands/Balance.hs index 755fb6ddc..fb2d1f56d 100644 --- a/hledger/Hledger/Cli/Commands/Balance.hs +++ b/hledger/Hledger/Cli/Commands/Balance.hs @@ -550,22 +550,42 @@ renderComponent topaligned oneline opts (acctname, dep, total) (FormatField ljus ,displayColour = color_ opts } + +headerCell :: Text -> Ods.Cell Ods.NumLines Text +headerCell text = + let deflt = Ods.defaultCell text + in + deflt { + Ods.cellStyle = Ods.Head, + Ods.cellBorder = + (Ods.cellBorder deflt) {Ods.borderBottom = Ods.DoubleLine} + } + +addTotalBorders :: [[Ods.Cell border text]] -> [[Ods.Cell Ods.NumLines text]] +addTotalBorders = + zipWith + (\border -> + map (\c -> c { + Ods.cellStyle = Ods.Body Ods.Total, + Ods.cellBorder = Ods.noBorder {Ods.borderTop = border}})) + (Ods.DoubleLine : repeat Ods.NoLine) + -- | Render a single-column balance report as FODS. -balanceReportAsSpreadsheet :: ReportOpts -> BalanceReport -> [[Ods.Cell Text]] +balanceReportAsSpreadsheet :: + ReportOpts -> BalanceReport -> [[Ods.Cell Ods.NumLines Text]] balanceReportAsSpreadsheet opts (items, total) = headers : concatMap (\(a, _, _, b) -> rows a b) items ++ if no_total_ opts then [] - else map (map (\c -> c {Ods.cellStyle = Ods.Body Ods.Total})) $ - rows totalRowHeadingCsv total + else addTotalBorders $ rows totalRowHeadingCsv total where cell = Ods.defaultCell headers = - map (\content -> (cell content) {Ods.cellStyle = Ods.Head}) $ + map headerCell $ "account" : case layout_ opts of LayoutBare -> ["commodity", "balance"] _ -> ["balance"] - rows :: AccountName -> MixedAmount -> [[Ods.Cell Text]] + rows :: AccountName -> MixedAmount -> [[Ods.Cell Ods.NumLines Text]] rows name ma = case layout_ opts of LayoutBare -> map (\a -> @@ -583,7 +603,9 @@ balanceReportAsSpreadsheet opts (items, total) = | layout_ opts == LayoutBare = (False, Just $ S.toList $ maCommodities mixedAmt) | otherwise = (True, Nothing) -cellFromMixedAmount :: AmountFormat -> MixedAmount -> Ods.Cell WideBuilder +cellFromMixedAmount :: + (Ods.Lines border) => + AmountFormat -> MixedAmount -> Ods.Cell border WideBuilder cellFromMixedAmount bopts mixedAmt = (Ods.defaultCell $ showMixedAmountB bopts mixedAmt) { Ods.cellType = @@ -592,7 +614,9 @@ cellFromMixedAmount bopts mixedAmt = Nothing -> Ods.TypeMixedAmount } -cellsFromMixedAmount :: AmountFormat -> MixedAmount -> [Ods.Cell WideBuilder] +cellsFromMixedAmount :: + (Ods.Lines border) => + AmountFormat -> MixedAmount -> [Ods.Cell border WideBuilder] cellsFromMixedAmount bopts mixedAmt = map (\(str,amt) -> @@ -630,14 +654,14 @@ multiBalanceReportAsCsvHelper ishtml opts = -- Helper for CSV and ODS and HTML rendering. multiBalanceReportAsSpreadsheetHelper :: - Bool -> ReportOpts -> MultiBalanceReport -> ([[Ods.Cell Text]], [[Ods.Cell Text]]) + Bool -> ReportOpts -> MultiBalanceReport -> + ([[Ods.Cell Ods.NumLines Text]], [[Ods.Cell Ods.NumLines Text]]) multiBalanceReportAsSpreadsheetHelper ishtml opts@ReportOpts{..} (PeriodicReport colspans items tr) = - (headers : concatMap fullRowAsTexts items, - map (map (\c -> c{Ods.cellStyle = Ods.Body Ods.Total})) totalrows) + (headers : concatMap fullRowAsTexts items, addTotalBorders totalrows) where cell = Ods.defaultCell headers = - map (\content -> (cell content) {Ods.cellStyle = Ods.Head}) $ + map headerCell $ "account" : case layout_ of LayoutTidy -> ["period", "start_date", "end_date", "commodity", "value"] @@ -782,7 +806,8 @@ multiBalanceReportHtmlFootRow ropts isfirstline (hdr:cells) = -- | Render the ODS table rows for a MultiBalanceReport. -- Returns the heading row, 0 or more body rows, and the totals row if enabled. multiBalanceReportAsSpreadsheet :: - ReportOpts -> MultiBalanceReport -> ((Maybe Int, Maybe Int), [[Ods.Cell Text]]) + ReportOpts -> MultiBalanceReport -> + ((Maybe Int, Maybe Int), [[Ods.Cell Ods.NumLines Text]]) multiBalanceReportAsSpreadsheet ropts mbr = let (upper,lower) = multiBalanceReportAsSpreadsheetHelper True ropts mbr in ((Just 1, case layout_ ropts of LayoutWide _ -> Just 1; _ -> Nothing), @@ -885,7 +910,8 @@ multiBalanceRowAsTextBuilders bopts ropts colspans row = multiBalanceRowAsCellBuilders bopts ropts colspans row multiBalanceRowAsCellBuilders :: - AmountFormat -> ReportOpts -> [DateSpan] -> PeriodicReportRow a MixedAmount -> [[Ods.Cell WideBuilder]] + AmountFormat -> ReportOpts -> [DateSpan] -> + PeriodicReportRow a MixedAmount -> [[Ods.Cell Ods.NumLines WideBuilder]] multiBalanceRowAsCellBuilders bopts ReportOpts{..} colspans (PeriodicReportRow _ as rowtot rowavg) = case layout_ of LayoutWide width -> [fmap (cellFromMixedAmount bopts{displayMaxWidth=width}) allamts] @@ -1192,14 +1218,15 @@ budgetReportAsCsv ropts report = map (map Ods.cellContent) $ budgetReportAsSpreadsheet ropts report -budgetReportAsSpreadsheet :: ReportOpts -> BudgetReport -> [[Ods.Cell Text]] +budgetReportAsSpreadsheet :: + ReportOpts -> BudgetReport -> [[Ods.Cell Ods.NumLines Text]] budgetReportAsSpreadsheet ReportOpts{..} (PeriodicReport colspans items totrow) = (if transpose_ then transpose else id) $ -- heading row - (map (\content -> (cell content) {Ods.cellStyle = Ods.Head}) $ + (map headerCell $ "Account" : ["Commodity" | layout_ == LayoutBare ] ++ concatMap (\spn -> [showDateSpan spn, "budget"]) colspans @@ -1211,7 +1238,7 @@ budgetReportAsSpreadsheet concatMap (rowAsTexts prrFullName) items -- totals row - ++ map (map (\c -> c {Ods.cellStyle = Ods.Body Ods.Total})) + ++ addTotalBorders (concat [ rowAsTexts (const totalRowHeadingBudgetCsv) totrow | not no_total_ ]) where @@ -1221,7 +1248,7 @@ budgetReportAsSpreadsheet rowAsTexts :: (PeriodicReportRow a BudgetCell -> Text) -> PeriodicReportRow a BudgetCell - -> [[Ods.Cell Text]] + -> [[Ods.Cell Ods.NumLines Text]] rowAsTexts render row@(PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg)) | layout_ /= LayoutBare = [cell (render row) : map showNorm vals] | otherwise =