hledger-lib 1.41 → 1.42

raw patch · 29 files changed

+408/−167 lines, 29 filesdep +encodingdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: encoding

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES.md +18/−1
• Hledger/Data/Amount.hs +9/−4
• Hledger/Data/Balancing.hs +1/−1
• Hledger/Data/Dates.hs +2/−1
• Hledger/Data/Journal.hs +19/−9
• Hledger/Data/Period.hs +11/−1
• Hledger/Data/Posting.hs +13/−5
• Hledger/Data/RawOptions.hs +4/−0
• Hledger/Data/Transaction.hs +6/−1
• Hledger/Data/Types.hs +3/−3
• Hledger/Read.hs +21/−11
• Hledger/Read/Common.hs +8/−2
• Hledger/Read/CsvReader.hs +5/−5
• Hledger/Read/InputOptions.hs +1/−1
• Hledger/Read/JournalReader.hs +6/−5
• Hledger/Read/RulesReader.hs +64/−19
• Hledger/Read/TimeclockReader.hs +1/−1
• Hledger/Read/TimedotReader.hs +1/−1
• Hledger/Reports/AccountTransactionsReport.hs +1/−1
• Hledger/Reports/EntriesReport.hs +3/−1
• Hledger/Reports/PostingsReport.hs +4/−4
• Hledger/Reports/ReportOptions.hs +5/−3
• Hledger/Utils/IO.hs +86/−18
• Hledger/Write/Html.hs +31/−28
• Hledger/Write/Html/Blaze.hs +8/−7
• Hledger/Write/Html/HtmlCommon.hs +39/−0
• Hledger/Write/Html/Lucid.hs +32/−28
• hledger-lib.cabal +5/−3
• test/unittest.hs +1/−3

@@ -22,7 +22,24 @@ For user-visible changes, see the hledger package changelog.  -# 2024-12-09 1.41+# 2025-03-07 1.42++Improvements++- readJournal, when not given a file name, now always assumes it is "-" rather than "(string)".+  [#2328]+- Make test/unittest.hs more buildable; remove PackageImports that was causing+  trouble for ghci.+  (Thomas Miedema, [#2337])+- Added: postingNegate+- Renamed: negatePostingAmount -> postingNegateMainAmount+- Refactor Hledger.Write.Html etc, reducing Lucid references.+  Clarify the HTML lib situation a bit, and clean up some imports.+  [#2244]+- Added: dropRawOpt, cliOptsDropArgs+- Hledger.Data.Amount: showAmountCost(B) now drops leading whitespace.++# 1.41 2024-12-09  Breaking changes 

@@ -88,6 +88,7 @@   showAmount,   showAmountWith,   showAmountB,+  showAmountCost,   showAmountCostB,   cshowAmount,   showAmountWithZeroCommodity,@@ -672,18 +673,22 @@     space = if not (T.null comm) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty     cost = if displayCost then showAmountCostB afmt a else mempty --- Show an amount's cost as @ UNITCOST or @@ TOTALCOST (builder version).+-- Show an amount's cost as @ UNITCOST or @@ TOTALCOST, plus a leading space, or "" if there's no cost.+showAmountCost :: Amount -> String+showAmountCost = wbUnpack . showAmountCostB defaultFmt++-- showAmountCost, efficient builder version. showAmountCostB :: AmountFormat -> Amount -> WideBuilder showAmountCostB afmt amt = case acost amt of-  Nothing              -> mempty+  Nothing             -> mempty   Just (UnitCost  pa) -> WideBuilder (TB.fromString " @ ")  3 <> showAmountB afmt pa   Just (TotalCost pa) -> WideBuilder (TB.fromString " @@ ") 4 <> showAmountB afmt (sign pa)   where sign = if aquantity amt < 0 then negate else id  showAmountCostDebug :: Maybe AmountCost -> String showAmountCostDebug Nothing                = ""-showAmountCostDebug (Just (UnitCost pa))  = " @ "  ++ showAmountDebug pa-showAmountCostDebug (Just (TotalCost pa)) = " @@ " ++ showAmountDebug pa+showAmountCostDebug (Just (UnitCost pa))  = "@ "  ++ showAmountDebug pa+showAmountCostDebug (Just (TotalCost pa)) = "@@ " ++ showAmountDebug pa  -- | Colour version. For a negative amount, adds ANSI codes to change the colour, -- currently to hard-coded red.

@@ -64,7 +64,7 @@   , infer_balancing_costs_ :: Bool  -- ^ Are we permitted to infer missing costs to balance transactions ?                                     --   Distinct from InputOpts{infer_costs_}.   , commodity_styles_      :: Maybe (M.Map CommoditySymbol AmountStyle)  -- ^ commodity display styles-  } deriving (Show)+  } deriving (Eq, Ord, Show)  defbalancingopts :: BalancingOpts defbalancingopts = BalancingOpts

@@ -218,7 +218,7 @@ -- >>> t (Months 2) 2008 01 01 2008 04 01 -- [DateSpan 2008-01-01..2008-02-29,DateSpan 2008-03-01..2008-04-30] -- >>> t (Weeks 1) 2008 01 01 2008 01 15--- [DateSpan 2007-W01,DateSpan 2008-W02,DateSpan 2008-W03]+-- [DateSpan 2008-W01,DateSpan 2008-W02,DateSpan 2008-W03] -- >>> t (Weeks 2) 2008 01 01 2008 01 15 -- [DateSpan 2007-12-31..2008-01-13,DateSpan 2008-01-14..2008-01-27] -- >>> t (MonthDay 2) 2008 01 01 2008   04 01@@ -252,6 +252,7 @@ splitSpan _      (DaysOfWeek days@(n:_))  ds = spansFromBoundaries e bdrys   where     (s, e) = dateSpanSplitLimits (nthdayofweekcontaining n) nextday ds+    -- can't show this when debugging, it'll hang:     bdrys = concatMap (flip map starts . addDays) [0,7..]     -- The first representative of each weekday     starts = map (\d -> addDays (toInteger $ d - n) $ nthdayofweekcontaining n s) days

@@ -1164,17 +1164,27 @@ pivotAccount fieldortagname p =   T.intercalate ":" [pivotComponent x p | x <- T.splitOn ":" fieldortagname] +-- | Get the value of the given field or tag for this posting.+-- "comm" and "cur" are accepted as synonyms meaning the commodity symbol.+-- Pivoting on an unknown field or tag, or on commodity when there are multiple commodities, returns "".+-- Pivoting on a tag when there are multiple values for that tag, returns the first value. pivotComponent :: Text -> Posting -> Text pivotComponent fieldortagname p-  |                           fieldortagname == "acct"        = paccount p-  | Just t <- ptransaction p, fieldortagname == "code"        = tcode t-  | Just t <- ptransaction p, fieldortagname == "desc"        = tdescription t-  | Just t <- ptransaction p, fieldortagname == "description" = tdescription t  -- backward compatible with 1.30 and older-  | Just t <- ptransaction p, fieldortagname == "payee"       = transactionPayee t-  | Just t <- ptransaction p, fieldortagname == "note"        = transactionNote t-  | Just t <- ptransaction p, fieldortagname == "status"      = T.pack . show . tstatus $ t-  | Just (_, value) <- postingFindTag fieldortagname p        = value-  | otherwise                                                 = ""+  | fieldortagname == "code",        Just t <- ptransaction p = tcode t+  | fieldortagname `elem` descnames, Just t <- ptransaction p = tdescription t+  | fieldortagname == "payee",       Just t <- ptransaction p = transactionPayee t+  | fieldortagname == "note",        Just t <- ptransaction p = transactionNote t+  | fieldortagname == "status",      Just t <- ptransaction p = T.pack . show . tstatus $ t+  | fieldortagname == "acct"        = paccount p+  | fieldortagname `elem` commnames = case map acommodity $ amounts $ pamount p of [s] -> s; _ -> unknown+  | fieldortagname == "amt"         = case amounts $ pamount p of [a] -> T.pack $ show $ aquantity a; _ -> unknown+  | fieldortagname == "cost"        = case amounts $ pamount p of [a@Amount{acost=Just _}] -> T.pack $ lstrip $ showAmountCost a; _ -> unknown+  | Just (_, tagvalue) <- postingFindTag fieldortagname p = tagvalue+  | otherwise = unknown+  where+    descnames = ["desc", "description"]   -- allow "description" for hledger <=1.30 compat+    commnames = ["cur","comm"]            -- allow either; cur is the query prefix, comm is more consistent+    unknown   = ""  postingFindTag :: TagName -> Posting -> Maybe (TagName, TagValue) postingFindTag tagname p = find ((tagname==) . fst) $ postingAllTags p

@@ -26,6 +26,7 @@   ,periodGrow   ,periodShrink   ,mondayBefore+  ,thursdayOfWeekContaining   ,yearMonthContainingWeekStarting   ,quarterContainingMonth   ,firstMonthOfQuarter@@ -174,9 +175,14 @@ -- -- >>> showPeriod (WeekPeriod (fromGregorian 2016 7 25)) -- "2016-W30"+-- >>> showPeriod (WeekPeriod (fromGregorian 2024 12 30))+-- "2025-W01" showPeriod :: Period -> Text showPeriod (DayPeriod b)       = T.pack $ formatTime defaultTimeLocale "%F" b              -- DATE-showPeriod (WeekPeriod b)      = T.pack $ formatTime defaultTimeLocale "%0Y-W%V" b         -- YYYY-Www+showPeriod (WeekPeriod b)      = T.pack $ y <> "-W" <> w                                   -- YYYY-Www+  where+    y = formatTime defaultTimeLocale "%0Y" $ thursdayOfWeekContaining b  -- be careful at year boundary+    w = formatTime defaultTimeLocale "%V" b showPeriod (MonthPeriod y m)   = T.pack $ printf "%04d-%02d" y m                           -- YYYY-MM showPeriod (QuarterPeriod y q) = T.pack $ printf "%04dQ%d" y q                             -- YYYYQN showPeriod (YearPeriod y)      = T.pack $ printf "%04d" y                                  -- YYYY@@ -190,6 +196,8 @@ -- an abbreviated form. -- >>> showPeriodAbbrev (WeekPeriod (fromGregorian 2016 7 25)) -- "W30"+-- >>> showPeriodAbbrev (WeekPeriod (fromGregorian 2024 12 30))+-- "W01" showPeriodAbbrev :: Period -> Text showPeriodAbbrev (MonthPeriod _ m)                                              -- Jan   | m > 0 && m <= length monthnames = T.pack . snd $ monthnames !! (m-1)@@ -324,6 +332,8 @@ mondayBefore d = addDays (1 - toInteger wd) d   where     (_,_,wd) = toWeekDate d++thursdayOfWeekContaining = (addDays 3).mondayBefore  yearMonthContainingWeekStarting weekstart = (y,m)   where

@@ -63,7 +63,8 @@    -- * arithmetic   sumPostings,-  negatePostingAmount,+  postingNegate,+  postingNegateMainAmount,   -- * rendering   showPosting,   showPostingLines,@@ -381,10 +382,17 @@ sumPostings :: [Posting] -> MixedAmount sumPostings = foldl' (\amt p -> maPlus amt $ pamount p) nullmixedamt --- | Negate amount in a posting.-negatePostingAmount :: Posting -> Posting-negatePostingAmount = postingTransformAmount negate+-- | Negate the posting's main amount and balance assertion amount if any.+postingNegate :: Posting -> Posting+postingNegate p@Posting{pamount=a, pbalanceassertion=mb} =+  p{pamount=negate a, pbalanceassertion=fmap balanceAssertionNegate mb}+  where+    balanceAssertionNegate b@BalanceAssertion{baamount=ba} = b{baamount=negate ba} +-- | Negate the posting's main amount but not the balance assertion amount.+postingNegateMainAmount :: Posting -> Posting+postingNegateMainAmount p@Posting{pamount=a} = p{pamount=negate a}+ -- | Strip all prices from a Posting. postingStripCosts :: Posting -> Posting postingStripCosts = postingTransformAmount mixedAmountStripCosts@@ -532,7 +540,7 @@ postingPriceDirectivesFromCost p@Posting{pamount} =     mapMaybe (amountPriceDirectiveFromCost $ postingDate p) $ amountsRaw pamount --- | Apply a transform function to this posting's amount.+-- | Apply a transform function to this posting's main amount (but not its balance assertion amount). postingTransformAmount :: (MixedAmount -> MixedAmount) -> Posting -> Posting postingTransformAmount f p@Posting{pamount=a} = p{pamount=f a} 

@@ -11,6 +11,7 @@   RawOpts,   mkRawOpts,   overRawOpts,+  dropRawOpt,   setopt,   setboolopt,   unsetboolopt,@@ -52,6 +53,9 @@  overRawOpts :: ([(String,String)] -> [(String,String)]) -> RawOpts -> RawOpts overRawOpts f = RawOpts . f . unRawOpts++dropRawOpt :: String -> RawOpts -> RawOpts+dropRawOpt a = overRawOpts $ filter (not.(==a).fst)  setopt :: String -> String -> RawOpts -> RawOpts setopt name val = overRawOpts (++ [(name, val)])

@@ -33,6 +33,7 @@ , transactionMapPostings , transactionMapPostingAmounts , transactionAmounts+, transactionNegate , partitionAndCheckConversionPostings , transactionAddTags , transactionAddHiddenAndMaybeVisibleTag@@ -478,9 +479,13 @@ transactionMapPostingAmounts :: (MixedAmount -> MixedAmount) -> Transaction -> Transaction transactionMapPostingAmounts f  = transactionMapPostings (postingTransformAmount f) --- | All posting amounts from this transactin, in order.+-- | All posting amounts from this transaction, in order. transactionAmounts :: Transaction -> [MixedAmount] transactionAmounts = map pamount . tpostings++-- | Flip the sign of this transaction's posting amounts (and balance assertion amounts).+transactionNegate :: Transaction -> Transaction+transactionNegate = transactionMapPostings postingNegate  -- | The file path from which this transaction was parsed. transactionFile :: Transaction -> FilePath

@@ -651,7 +651,7 @@                                                                       --   any included journal files. The main file is first,                                                                       --   followed by any included files in the order encountered.                                                                       --   TODO: FilePath is a sloppy type here, don't assume it's a-                                                                      --   real file; values like "", "-", "(string)" can be seen+                                                                      --   real file; values like "" or "-" can be seen   ,jlastreadtime            :: POSIXTime                              -- ^ when this journal was last read from its file(s)   -- NOTE: after adding new fields, eg involving account names, consider updating   -- the Anon instance in Hleger.Cli.Anon@@ -666,7 +666,7 @@   = Csv  -- comma-separated   | Tsv  -- tab-separated   | Ssv  -- semicolon-separated-  deriving Eq+  deriving (Eq, Ord)  -- | The id of a data format understood by hledger, eg @journal@ or @csv@. -- The --output-format option selects one of these for output.@@ -677,7 +677,7 @@   | Timeclock    | Timedot    | Sep SepFormat -  deriving Eq+  deriving (Eq, Ord)  instance Show SepFormat where   show Csv = "csv"

@@ -102,6 +102,7 @@    -- * Easy journal parsing   readJournal',+  readJournal'',   readJournalFile',   readJournalFiles',   orDieTrying,@@ -125,7 +126,7 @@  --- ** imports import qualified Control.Exception as C-import Control.Monad (unless, when, forM)+import Control.Monad (unless, when, forM, (<=<)) import "mtl" Control.Monad.Except (ExceptT(..), runExceptT, liftEither) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Default (def)@@ -145,7 +146,7 @@ import System.Exit (exitFailure) import System.FilePath ((<.>), (</>), splitDirectories, splitFileName, takeFileName) import System.Info (os)-import System.IO (hPutStr, stderr)+import System.IO (Handle, hPutStr, stderr)  import Hledger.Data.Dates (getCurrentDay, parsedateM, showDate) import Hledger.Data.Types@@ -205,7 +206,7 @@  -- | @readJournal iopts mfile txt@ ----- Read a Journal from some text, with strict checks if enabled,+-- Read a Journal from some handle, with strict checks if enabled, -- or return an error message. -- -- The reader (data format) is chosen based on, in this order:@@ -217,13 +218,17 @@ -- - a file extension in @mfile@ -- -- If none of these is available, or if the reader name is unrecognised,--- we use the journal reader (for predictability).+-- the journal reader is used. ---readJournal :: InputOpts -> Maybe FilePath -> Text -> ExceptT String IO Journal-readJournal iopts@InputOpts{strict_, _defer} mpath txt = do+-- If a file path is not provided, "-" is assumed (and may appear in error messages,+-- `files` output etc, where it will be a slight lie: it will mean "not from a file",+-- not necessarily "from standard input".+--+readJournal :: InputOpts -> Maybe FilePath -> Handle -> ExceptT String IO Journal+readJournal iopts@InputOpts{strict_, _defer} mpath hdl = do   let r :: Reader IO = fromMaybe JournalReader.reader $ findReader (mformat_ iopts) mpath   dbg6IO "readJournal: trying reader" (rFormat r)-  j <- rReadFn r iopts (fromMaybe "(string)" mpath) txt+  j <- rReadFn r iopts (fromMaybe "-" mpath) hdl   when (strict_ && not _defer) $ liftEither $ journalStrictChecks j   return j @@ -264,11 +269,11 @@     (mfmt, f) = splitReaderPrefix prefixedfile     iopts' = iopts{mformat_=asum [mfmt, mformat_ iopts]}   liftIO $ requireJournalFileExists f-  t <-+  h <-     traceOrLogAt 6 ("readJournalFile: "++takeFileName f) $-    liftIO $ readFileOrStdinPortably f+    liftIO $ openFileOrStdin f     -- <- T.readFile f  -- or without line ending translation, for testing-  j <- readJournal iopts' (Just f) t+  j <- readJournal iopts' (Just f) h   if new_ iopts     then do       ds <- liftIO $ previousLatestDates f@@ -313,8 +318,13 @@  -- | An easy version of 'readJournal' which assumes default options, and fails -- in the IO monad.-readJournal' :: Text -> IO Journal+readJournal' :: Handle -> IO Journal readJournal' = orDieTrying . readJournal definputopts Nothing++-- | An even easier version of 'readJournal' which additionally to 'readJournal''+-- also takes a 'Text' instead of a 'Handle'.+readJournal'' :: Text -> IO Journal+readJournal'' = readJournal' <=< inputToHandle  -- | An easy version of 'readJournalFile' which assumes default options, and fails -- in the IO monad.

@@ -34,6 +34,7 @@   HasInputOpts(..),   definputopts,   rawOptsToInputOpts,+  handleReadFnToTextReadFn,    -- * parsing utilities   parseAndFinaliseJournal,@@ -148,6 +149,7 @@ import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..)) import Data.Word (Word8) import System.FilePath (takeFileName)+import System.IO (Handle) import Text.Megaparsec import Text.Megaparsec.Char (char, char', digitChar, newline, string) import Text.Megaparsec.Char.Lexer (decimal)@@ -179,9 +181,9 @@     ,rExtensions :: [String]       -- The entry point for reading this format, accepting input options, file-     -- path for error messages and file contents, producing an exception-raising IO+     -- path for error messages and file contents via the handle, producing an exception-raising IO      -- action that produces a journal or error message.-    ,rReadFn   :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal+    ,rReadFn   :: InputOpts -> FilePath -> Handle -> ExceptT String IO Journal       -- The actual megaparsec parser called by the above, in case      -- another parser (includedirectivep) wants to use it directly.@@ -230,6 +232,10 @@       ,strict_            = boolopt "strict" rawopts       ,_ioDay             = day       }++handleReadFnToTextReadFn :: (InputOpts -> FilePath -> Text -> ExceptT String IO Journal) -> InputOpts -> FilePath -> Handle -> ExceptT String IO Journal+handleReadFnToTextReadFn p iopts fp =+  p iopts fp <=< lift . readHandlePortably  -- | Get the date span from --forecast's PERIODEXPR argument, if any. -- This will fail with a usage error if the period expression cannot be parsed,

@@ -28,7 +28,7 @@ import Prelude hiding (Applicative(..)) import Control.Monad.Except       (ExceptT(..), liftEither) import Control.Monad.IO.Class     (MonadIO)-import Data.Text (Text)+import System.IO                  (Handle)  import Hledger.Data import Hledger.Utils@@ -54,10 +54,10 @@ -- This file path is normally the CSV(/SSV/TSV) data file, and a corresponding rules file is inferred. -- But it can also be the rules file, in which case the corresponding data file is inferred. -- This does not check balance assertions.-parse :: SepFormat -> InputOpts -> FilePath -> Text -> ExceptT String IO Journal-parse sep iopts f t = do+parse :: SepFormat -> InputOpts -> FilePath -> Handle -> ExceptT String IO Journal+parse sep iopts f h = do   let mrulesfile = mrules_file_ iopts-  readJournalFromCsv (Right <$> mrulesfile) f t (Just sep)+  readJournalFromCsv (Right <$> mrulesfile) f h (Just sep)   -- apply any command line account aliases. Can fail with a bad replacement pattern.   >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)       -- journalFinalise assumes the journal's items are@@ -65,7 +65,7 @@       -- But here they are already properly ordered. So we'd       -- better preemptively reverse them once more. XXX inefficient       . journalReverse-  >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f t+  >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f ""  --- ** tests 

@@ -44,7 +44,7 @@     ,strict_            :: Bool                 -- ^ do extra correctness checks ?     ,_defer             :: Bool                 -- ^ internal flag: postpone checks, because we are processing multiple files ?     ,_ioDay             :: Day                  -- ^ today's date, for use with forecast transactions  XXX this duplicates _rsDay, and should eventually be removed when it's not needed anymore.- } deriving (Show)+ } deriving (Eq, Ord, Show)  definputopts :: InputOpts definputopts = InputOpts

@@ -194,7 +194,7 @@ reader = Reader   {rFormat     = Journal'   ,rExtensions = ["journal", "j", "hledger", "ledger"]-  ,rReadFn     = parse+  ,rReadFn     = handleReadFnToTextReadFn parse   ,rParser    = journalp  -- no need to add command line aliases like journalp'                            -- when called as a subparser I think   }@@ -282,10 +282,11 @@    ]   ) <?> "directive" --- | Parse an include directive. include's argument is an optionally--- file-format-prefixed file path or glob pattern. In the latter case,--- the prefix is applied to each matched path. Examples:--- foo.j, foo/bar.j, timedot:foo/2020*.md+-- | Parse an include directive, and the file(s) it refers to, possibly recursively.+-- include's argument is a file path or glob pattern, optionally with a file type prefix.+-- ~ at the start is expanded to the user's home directory.+-- Relative paths are relative to the current file.+-- Examples: foo.j, ../foo/bar.j, timedot:/foo/2020*, *.journal includedirectivep :: MonadIO m => ErroringJournalParser m () includedirectivep = do   string "include"

@@ -52,6 +52,7 @@ import Control.Monad.Trans.Class  (lift) import Data.Char                  (toLower, isDigit, isSpace, isAlphaNum, ord) import Data.Bifunctor             (first)+import Data.Encoding              (encodingFromStringExplicit) import Data.Functor               ((<&>)) import Data.List (elemIndex, mapAccumL, nub, sortOn) #if !MIN_VERSION_base(4,20,0)@@ -69,6 +70,7 @@   defaultTimeLocale, getCurrentTimeZone, localDay, parseTimeM, utcToLocalTime, localTimeToUTC, zonedTimeToUTC) import Safe (atMay, headMay, lastMay, readMay) import System.FilePath ((</>), takeDirectory, takeExtension, stripExtension, takeFileName)+import System.IO       (Handle, hClose) import qualified Data.Csv as Cassava import qualified Data.Csv.Parser.Megaparsec as CassavaMegaparsec import qualified Data.ByteString as B@@ -116,10 +118,11 @@ -- file's directory. When a glob pattern matches multiple files, the alphabetically -- last is used. (Eg in case of multiple numbered downloads, the highest-numbered -- will be used.)--- The provided text, or a --rules option, are ignored by this reader.+-- The provided handle, or a --rules option, are ignored by this reader. -- Balance assertions are not checked.-parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal-parse iopts f _ = do+parse :: InputOpts -> FilePath -> Handle -> ExceptT String IO Journal+parse iopts f h = do+  lift $ hClose h -- We don't need it   rules <- readRulesFile $ dbg4 "reading rules file" f   -- XXX higher-than usual debug level for file reading to bypass excessive noise from elsewhere, normally 6 or 7   mdatafile <- liftIO $ do@@ -139,8 +142,8 @@       if not (dat=="-" || exists)       then return nulljournal      -- data file inferred from rules file name was not found       else do-        t <- liftIO $ readFileOrStdinPortably dat-        readJournalFromCsv (Just $ Left rules) dat t Nothing+        dath <- liftIO $ openFileOrStdin dat+        readJournalFromCsv (Just $ Left rules) dat dath Nothing         -- apply any command line account aliases. Can fail with a bad replacement pattern.         >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)             -- journalFinalise assumes the journal's items are@@ -500,6 +503,7 @@ directives :: [Text] directives =   ["source"+  ,"encoding"   ,"date-format"   ,"decimal-mark"   ,"separator"@@ -633,20 +637,20 @@                  ])   when (null body) $     customFailure $ parseErrorAt start $ "start of conditional table found, but no assignment rules afterward"-  return $ flip map body $ \(m,vs) ->-    CB{cbMatchers=[m], cbAssignments=zip fields vs}+  return $ flip map body $ \(ms,vs) ->+    CB{cbMatchers=ms, cbAssignments=zip fields vs}   <?> "conditional table"   where-    bodylinep :: Char -> [Text] -> CsvRulesParser (Matcher,[FieldTemplate])+    bodylinep :: Char -> [Text] -> CsvRulesParser ([Matcher],[FieldTemplate])     bodylinep sep fields = do       off <- getOffset-      m <- matcherp' $ void $ char sep+      ms <- matcherp' (lookAhead . void . char $ sep) `manyTill` char sep       vs <- T.split (==sep) . T.pack <$> lift restofline       if (length vs /= length fields)         then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d" (length fields) (length vs)) :: String)-        else return (m,vs)-      +        else return (ms,vs) + -- A single matcher, on one line. -- This tries to parse first as a field matcher, then if that fails, as a whole-record matcher; -- the goal was to not break legacy whole-record patterns that happened to look a bit like a field matcher@@ -696,7 +700,7 @@ matcherprefixp = do   lift $ dbgparse 8 "trying matcherprefixp"   (do-    char '&' >> lift skipNonNewlineSpaces+    char '&' >> optional (char '&') >> lift skipNonNewlineSpaces     fromMaybe And <$> optional (char '!' >> lift skipNonNewlineSpaces >> return AndNot))   <|> (char '!' >> lift skipNonNewlineSpaces >> return Not)   <|> return Or@@ -714,10 +718,12 @@   lift $ dbgparse 8 "trying regexp"   -- notFollowedBy matchoperatorp   c <- lift nonspace-  cs <- anySingle `manyTill` end+  cs <- anySingle `manyTill` (double_ampersand <|> end)   case toRegexCI . T.strip . T.pack $ c:cs of        Left x -> Fail.fail $ "CSV parser: " ++ x        Right x -> return x+  where+    double_ampersand = lookAhead . void $ char '&' >> char '&'  -- -- A match operator, indicating the type of match to perform. -- -- Currently just ~ meaning case insensitive infix regex match.@@ -908,9 +914,9 @@ -- -- 4. Return the transactions as a Journal. ---readJournalFromCsv :: Maybe (Either CsvRules FilePath) -> FilePath -> Text -> Maybe SepFormat -> ExceptT String IO Journal-readJournalFromCsv Nothing "-" _ _ = throwError "please use --rules when reading CSV from stdin"-readJournalFromCsv merulesfile csvfile csvtext sep = do+readJournalFromCsv :: Maybe (Either CsvRules FilePath) -> FilePath -> Handle -> Maybe SepFormat -> ExceptT String IO Journal+readJournalFromCsv Nothing "-" h _ = lift (hClose h) *> throwError "please use --rules when reading CSV from stdin"+readJournalFromCsv merulesfile csvfile csvhandle sep = do     -- for now, correctness is the priority here, efficiency not so much      rules <- case merulesfile of@@ -919,6 +925,16 @@       Nothing                -> readRulesFile $ rulesFileFor csvfile     dbg6IO "csv rules" rules +    -- read csv while being aware of the encoding+    mencoding <- do+      -- XXX higher-than usual debug level for file reading to bypass excessive noise from elsewhere, normally 6 or 7+      case T.unpack <$> getDirective "encoding" rules of+        Just rawenc -> case encodingFromStringExplicit $ dbg4 "raw-encoding" rawenc of+          Just enc -> return . Just $ dbg4 "encoding" enc+          Nothing -> throwError $ "Invalid encoding: " <> rawenc+        Nothing  -> return Nothing+    csvtext <- lift $ readHandlePortably' mencoding csvhandle+     -- convert the csv data to lines and remove all empty/blank lines     let csvlines1 = dbg9 "csvlines1" $ filter (not . T.null . T.strip) $ dbg9 "csvlines0" $ T.lines csvtext @@ -1545,7 +1561,7 @@    ,testCase "quoted name" $ parseWithState' defrules csvfieldreferencep "%\"csv date\"" @?= (Right "%\"csv date\"")    ] -  ,testGroup "matcherp" [+  ,testGroup "recordmatcherp" [      testCase "recordmatcherp" $       parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher Or $ toRegexCI' "A A")@@ -1553,18 +1569,47 @@    ,testCase "recordmatcherp.starts-with-&" $       parseWithState' defrules matcherp "& A A\n" @?= (Right $ RecordMatcher And $ toRegexCI' "A A") -   ,testCase "fieldmatcherp.starts-with-%" $+   ,testCase "recordmatcherp.starts-with-&&" $+      parseWithState' defrules matcherp "&& A A\n" @?= (Right $ RecordMatcher And $ toRegexCI' "A A")++   ,testCase "recordmatcherp.starts-with-&&-!" $+      parseWithState' defrules matcherp "&& ! A A\n" @?= (Right $ RecordMatcher AndNot $ toRegexCI' "A A")++   ,testCase "recordmatcherp.does-not-start-with-%" $       parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher Or $ toRegexCI' "description A A")+   ] -   ,testCase "fieldmatcherp" $+  ,testGroup "fieldmatcherp" [+    testCase "fieldmatcherp" $       parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher Or "%description" $ toRegexCI' "A A")     ,testCase "fieldmatcherp.starts-with-&" $       parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A") +   ,testCase "fieldmatcherp.starts-with-&&" $+      parseWithState' defrules matcherp "&& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A")++   ,testCase "fieldmatcherp.starts-with-&&-!" $+      parseWithState' defrules matcherp "&& ! %description A A\n" @?= (Right $ FieldMatcher AndNot "%description" $ toRegexCI' "A A")+    -- ,testCase "fieldmatcherp with operator" $    --    parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A")+   ] +  ,testGroup "regexp" [+    testCase "regexp.ends-before-&&" $+      parseWithState' defrules (regexp empty) "A A && xxx" @?= (Right $ toRegexCI' "A A")+   ]++  , let matchers = [RecordMatcher Or (toRegexCI' "A"), RecordMatcher And (toRegexCI' "B")]+        assignments = [("account2", "foo"), ("comment2", "bar")]+        block = CB matchers assignments+    in+   testGroup "Combine multiple matchers on the same line" [+    testCase "conditionalblockp" $+      parseWithState' defrules conditionalblockp "if A && B\n account2 foo\n comment2 bar" @?= (Right block)+   ,testCase "conditionaltablep" $+      parseWithState' defrules conditionaltablep "if,account2,comment2\nA && B,foo,bar" @?= (Right [block])    ]   ,testGroup "hledgerField" [

@@ -79,7 +79,7 @@ reader = Reader   {rFormat     = Timeclock   ,rExtensions = ["timeclock"]-  ,rReadFn     = parse+  ,rReadFn     = handleReadFnToTextReadFn parse   ,rParser    = timeclockfilep   } 

@@ -68,7 +68,7 @@ reader = Reader   {rFormat     = Timedot   ,rExtensions = ["timedot"]-  ,rReadFn     = parse+  ,rReadFn     = handleReadFnToTextReadFn parse   ,rParser    = timedotp   } 

@@ -162,7 +162,7 @@       . traceAtWith 5 (("ts4:\n"++).pshowTransactions.map snd)       . sortBy (comparing (Down . fst) <> comparing (Down . tindex . snd))       . map (\t -> (transactionRegisterDate wd reportq thisacctq t, t))-      . map (if invert_ ropts then (\t -> t{tpostings = map negatePostingAmount $ tpostings t}) else id)+      . map (if invert_ ropts then (\t -> t{tpostings = map postingNegateMainAmount $ tpostings t}) else id)       $ jtxns acctJournal  pshowTransactions :: [Transaction] -> String

@@ -35,7 +35,9 @@ -- | Select transactions for an entries report. entriesReport :: ReportSpec -> Journal -> EntriesReport entriesReport rspec@ReportSpec{_rsReportOpts=ropts} =-    sortBy (comparing $ transactionDateFn ropts) . jtxns+      sortBy (comparing $ transactionDateFn ropts)+    . map  (if invert_ ropts then transactionNegate else id)+    . jtxns     . journalApplyValuationFromOpts (setDefaultConversionOp NoConversionOp rspec)     . filterJournalTransactions (filterQuery (not.queryIsDepth) $ _rsQuery rspec) 

@@ -158,7 +158,7 @@     beforestartq = dbg3 "beforestartq" $ dateqtype $ DateSpan Nothing (Exact <$> spanStart reportspan)     beforeandduringps =          sortOn (postingDateOrDate2 (whichDate ropts))            -- sort postings by date or date2-      . (if invert_ ropts then map negatePostingAmount else id)  -- with --invert, invert amounts+      . (if invert_ ropts then map postingNegateMainAmount else id)  -- with --invert, invert amounts       . journalPostings       -- With most calls we will not require transaction prices past this point, and can get a big       -- speed improvement by stripping them early. In some cases, such as in hledger-ui, we still@@ -301,7 +301,7 @@       ,"postings report with cleared option" ~:        do         let opts = defreportopts{cleared_=True}-        j <- readJournal' sample_journal_str+        j <- readJournal'' sample_journal_str         (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines          ["2008/06/03 eat & shop           expenses:food                    $1           $1"          ,"                                expenses:supplies                $1           $2"@@ -313,7 +313,7 @@       ,"postings report with uncleared option" ~:        do         let opts = defreportopts{uncleared_=True}-        j <- readJournal' sample_journal_str+        j <- readJournal'' sample_journal_str         (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines          ["2008/01/01 income               assets:bank:checking             $1           $1"          ,"                                income:salary                   $-1            0"@@ -325,7 +325,7 @@        ,"postings report sorts by date" ~:        do-        j <- readJournal' $ unlines+        j <- readJournal'' $ unlines             ["2008/02/02 a"             ,"  b  1"             ,"  c"

@@ -88,7 +88,6 @@ import Hledger.Utils import Data.Function ((&)) - -- | What to calculate for each cell in a balance report. -- "Balance report types -> Calculation type" in the hledger manual. data BalanceCalculation =@@ -890,10 +889,13 @@ -- Left "This regular expression is invalid or unsupported, please correct it:\n(assets" -- >>> _rsQuery $ set querystring ["assets"] defreportspec -- Acct (RegexpCI "assets")--- >>> _rsQuery $ set querystring ["(assets"] defreportspec--- *** Exception: Error: Updating ReportSpec failed: try using overEither instead of over or setEither instead of set -- >>> _rsQuery $ set period (MonthPeriod 2021 08) defreportspec -- Date DateSpan 2021-08+--+-- XXX testing error output isn't working since adding color to it:+-- > import System.Environment+-- > setEnv "NO_COLOR" "1" >> return (_rsQuery $ set querystring ["(assets"] defreportspec)+-- *** Exception: Error: Updating ReportSpec failed: try using overEither instead of over or setEither instead of set class HasReportOptsNoUpdate a => HasReportOpts a where     reportOpts :: ReportableLens' a ReportOpts     reportOpts = reportOptsNoUpdate

@@ -4,7 +4,9 @@ terminals, pager output, ANSI colour/styles, etc. -} +{-# LANGUAGE ImplicitParams      #-} {-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE PackageImports      #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -31,11 +33,15 @@   expandPath,   expandGlob,   sortByModTime,+  openFileOrStdin,   readFileOrStdinPortably,+  readFileOrStdinPortably',   readFileStrictly,   readFilePortably,   readHandlePortably,+  readHandlePortably',   -- hereFileRelative,+  inputToHandle,    -- * Command line parsing   progArgs,@@ -83,6 +89,7 @@   brightCyan',   brightWhite',   rgb',+  sgrresetall,    -- ** Generic @@ -110,6 +117,7 @@ import           Data.Colour.RGBSpace (RGB(RGB)) import           Data.Colour.RGBSpace.HSL (lightness) import           Data.Colour.SRGB (sRGB)+import           Data.Encoding (DynEncoding) import           Data.FileEmbed (makeRelativeToProject, embedStringFile) import           Data.Functor ((<&>)) import           Data.List hiding (uncons)@@ -135,8 +143,9 @@ import "Glob"    System.FilePath.Glob (glob) import           System.Info (os) import           System.IO (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode, openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom, hIsTerminalDevice, hPutStr, hClose)+import qualified System.IO.Encoding as Enc import           System.IO.Unsafe (unsafePerformIO)-import           System.Process (CreateProcess(..), StdStream(CreatePipe), shell, waitForProcess, withCreateProcess)+import           System.Process (CreateProcess(..), StdStream(CreatePipe), createPipe, shell, waitForProcess, withCreateProcess) import           Text.Pretty.Simple (CheckColorTty(..), OutputOptions(..), defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)  import Hledger.Utils.Text (WideBuilder(WideBuilder))@@ -186,22 +195,39 @@  -- Errors --- | Simpler alias for errorWithoutStackTrace+-- | Call errorWithoutStackTrace, prepending a "Error:" label.+-- Also do some ANSI styling of the first line when allowed (using unsafe IO). error' :: String -> a-error' = errorWithoutStackTrace . ("Error: " <>)+error' =+  if useColorOnStderrUnsafe+  then  -- color the program name as well+    unsafePerformIO $ do+      putStr fmt+      return $ errorWithoutStackTrace . modifyFirstLine ((<>sgrresetall) . (label<>))+  else+    errorWithoutStackTrace . modifyFirstLine (label<>)+  where+    label = "Error: "+    fmt = sgrbrightred <> sgrbold --- | A version of errorWithoutStackTrace that adds a usage hint.+-- | Like error', but add a hint about using -h. usageError :: String -> a usageError = error' . (++ " (use -h to see usage)") --- | Show a warning message on stderr before returning the given value.--- Use this when you want to show the user a message on stderr, without stopping the program.--- Currently we do this very sparingly in hledger; we prefer to either quietly work,--- or loudly raise an error. Variable output can make scripting harder.+-- | Show a message, with "Warning:" label, on stderr before returning the given value.+-- Also do some ANSI styling of the first line when we detect that's supported (using unsafe IO).+-- Currently we use this very sparingly in hledger; we prefer to either quietly work,+-- or loudly raise an error. (Varying output can make scripting harder.) warn :: String -> a -> a-warn msg = trace ("Warning: " <> msg)-+warn msg = trace (modifyFirstLine f (label <> msg))+  where+    label = "Warning: "+    f = if useColorOnStderrUnsafe then ((<>sgrresetall).(fmt<>)) else id+      where+        fmt = sgrbrightyellow <> sgrbold +-- Transform a string's first line.+modifyFirstLine f s = unlines $ map f l <> ls where (l,ls) = splitAt 1 $ lines s  -- total  -- Time @@ -262,20 +288,40 @@  -- | Like readFilePortably, but read from standard input if the path is "-". readFileOrStdinPortably :: String -> IO T.Text-readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably-  where-    openFileOrStdin :: String -> IOMode -> IO Handle-    openFileOrStdin "-" _ = return stdin-    openFileOrStdin f' m   = openFile f' m+readFileOrStdinPortably = readFileOrStdinPortably' Nothing +-- | Like readFileOrStdinPortably, but take an optional converter.+readFileOrStdinPortably' :: Maybe DynEncoding -> String -> IO T.Text+readFileOrStdinPortably' c f = openFileOrStdin f >>= readHandlePortably' c++openFileOrStdin :: String -> IO Handle+openFileOrStdin "-" = return stdin+openFileOrStdin f' = openFile f' ReadMode+ readHandlePortably :: Handle -> IO T.Text-readHandlePortably h = do+readHandlePortably = readHandlePortably' Nothing++readHandlePortably' :: Maybe DynEncoding -> Handle -> IO T.Text+readHandlePortably' Nothing h = do   hSetNewlineMode h universalNewlineMode   menc <- hGetEncoding h   when (fmap show menc == Just "UTF-8") $  -- XXX no Eq instance, rely on Show     hSetEncoding h utf8_bom   T.hGetContents h+readHandlePortably' (Just e) h =+  -- We need to manually apply the newline mode+  -- Since we already have a Text+  T.replace "\r\n" "\n" . T.pack <$> let ?enc = e in Enc.hGetContents h +inputToHandle :: T.Text -> IO Handle+inputToHandle t = do+  (r, w) <- createPipe+  hSetEncoding r utf8_bom+  hSetEncoding w utf8_bom+  T.hPutStr w t+  hClose w+  return r+ -- | Like embedFile, but takes a path relative to the package directory. embedFileRelative :: FilePath -> Q Exp embedFileRelative f = makeRelativeToProject f >>= embedStringFile@@ -367,8 +413,29 @@  -- Terminal size +-- [NOTE: Alternative methods of getting the terminal size]+-- terminal-size uses the TIOCGWINSZ ioctl to get the window size on Unix+-- systems, which may not be completely portable according to people in+-- #linux@liberachat.+--+-- If this turns out to be the case, supplementary coverage can be given by+-- using the terminfo package.+--+-- Conversely, terminfo on its own is not a full solution, firstly because it+-- only works on Unix (not Windows), and secondly since in some scenarios (eg+-- stripped-down build systems) the terminfo database may be limited and lack+-- the correct entries. (A hack that sometimes works but which isn't robust+-- enough to be relied upon is to set TERM=dumb -- while this advice does appear+-- in some places, it's not guaranteed to work)+--+-- In any case, $LINES/$COLUMNS should not be used as a source for the terminal+-- size - they are not available or do not update reliably in all shells.+--+-- See #2332 for details+ -- | An alternative to ansi-terminal's getTerminalSize, based on -- the more robust-looking terminal-size package.+-- -- Tries to get stdout's terminal's current height and width. getTerminalHeightWidth :: IO (Maybe (Int,Int)) getTerminalHeightWidth = fmap (fmap unwindow) size@@ -401,7 +468,6 @@ --   --shift=8 --   --squeeze-blank-lines --   --use-backslash---   --use-color -- -- You can choose different options by setting the HLEDGER_LESS variable; -- if set, its value will be used instead of LESS.@@ -424,7 +490,7 @@       ,"--shift=8"       ,"--squeeze-blank-lines"       ,"--use-backslash"-      ,"--use-color"+      -- ,"--use-color"  #2335 rejected by older less versions (eg 551)       ]   mhledgerless <- lookupEnv "HLEDGER_LESS"   mless        <- lookupEnv "LESS"@@ -554,6 +620,8 @@ sgrfaint         = setSGRCode [SetConsoleIntensity FaintIntensity] sgrnormal        = setSGRCode [SetConsoleIntensity NormalIntensity] sgrresetfg       = setSGRCode [SetDefaultColor Foreground]+sgrresetbg       = setSGRCode [SetDefaultColor Background]+sgrresetall      = sgrresetfg <> sgrresetbg <> sgrnormal sgrblack         = setSGRCode [SetColor Foreground Dull Black] sgrred           = setSGRCode [SetColor Foreground Dull Red] sgrgreen         = setSGRCode [SetColor Foreground Dull Green]

@@ -1,38 +1,41 @@-{-# LANGUAGE OverloadedStrings #-} {- |-Common definitions for Html.Blaze and Html.Lucid+HTML writing helpers.+This module would ideally hide the details of which HTML library is used, but it doesn't yet.++Currently hledger-web uses blaze-html, but hledger CLI reports use lucid.+lucid has a more usable API than blaze-html (https://chrisdone.com/posts/lucid).+lucid2's is even better.+Unfortunately lucid* can not render multi-line or indented text.+We want this so that humans can read and troubleshoot our HTML output.+So a transition to blaze-html may be coming.+ -}-module Hledger.Write.Html (-    Lines(..),-    borderStyles,-    ) where -import qualified Hledger.Write.Spreadsheet as Spr-import Hledger.Write.Spreadsheet (Cell(..))+{-# LANGUAGE OverloadedStrings #-} -import Data.Text (Text)+module Hledger.Write.Html (+  L.toHtml,+  Html,+  formatRow,+  htmlAsText,+  htmlAsLazyText,+  styledTableHtml,+  tests_Hledger_Write_Html+  ) where +import qualified Data.Text as T (Text)+import qualified Data.Text.Lazy as TL (Text, toStrict)+import qualified Lucid as L (renderText, toHtml)+import Test.Tasty (testGroup) -borderStyles :: Lines border => Cell border text -> [Text]-borderStyles cell =-    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-    leftBorder++rightBorder++topBorder++bottomBorder+import Hledger.Write.Html.Lucid (Html, formatRow, styledTableHtml)  -class (Spr.Lines border) => Lines border where-    borderLines :: border -> [Text]+htmlAsText :: Html -> T.Text+htmlAsText = TL.toStrict . L.renderText -instance Lines () where-    borderLines () = []+htmlAsLazyText :: Html -> TL.Text+htmlAsLazyText = L.renderText -instance Lines Spr.NumLines where-    borderLines prop =-        case prop of-            Spr.NoLine -> []-            Spr.SingleLine -> ["black"]-            Spr.DoubleLine -> ["double black"]+tests_Hledger_Write_Html = testGroup "Write.Html" [+  ]

@@ -1,18 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} {- |-Export spreadsheet table data as HTML table.--This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>+HTML writing helpers using blaze-html. -}+ module Hledger.Write.Html.Blaze (-    printHtml,+    styledTableHtml,     formatRow,     formatCell,     ) where  import qualified Hledger.Write.Html.Attribute as Attr import qualified Hledger.Write.Spreadsheet as Spr-import Hledger.Write.Html (Lines, borderStyles)+import Hledger.Write.Html.HtmlCommon (Lines, borderStyles) import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))  import qualified Text.Blaze.Html4.Transitional.Attributes as HtmlAttr@@ -22,8 +21,10 @@ import Data.Foldable (traverse_)  -printHtml :: (Lines border) => [[Cell border Html]] -> Html-printHtml table = do+-- | Export spreadsheet table data as HTML table.+-- This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>+styledTableHtml :: (Lines border) => [[Cell border Html]] -> Html+styledTableHtml table = do     Html.style $ toHtml $ Attr.tableStylesheet     Html.table $ traverse_ formatRow table 

@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Common definitions used by both Html.Blaze and Html.Lucid.+-}++module Hledger.Write.Html.HtmlCommon (+    Lines(..),+    borderStyles,+    ) where++import Data.Text (Text)++import           Hledger.Write.Spreadsheet (Cell(..))+import qualified Hledger.Write.Spreadsheet as Spr+++borderStyles :: Lines border => Cell border text -> [Text]+borderStyles cell =+    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+    leftBorder++rightBorder++topBorder++bottomBorder+++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"]

@@ -1,36 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} {- |-Export spreadsheet table data as HTML table.--This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>+HTML writing helpers using lucid. -}+ module Hledger.Write.Html.Lucid (-    printHtml,+    Html,+    L.toHtml,+    styledTableHtml,     formatRow,     formatCell,     ) where +import           Data.Foldable (traverse_)+import qualified Data.Text as Text+import qualified Lucid.Base as L+import qualified Lucid as L+ import qualified Hledger.Write.Html.Attribute as Attr+import           Hledger.Write.Html.HtmlCommon+import           Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..)) import qualified Hledger.Write.Spreadsheet as Spr-import Hledger.Write.Html (Lines, borderStyles)-import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..)) -import qualified Data.Text as Text-import qualified Lucid.Base as HtmlBase-import qualified Lucid as Html-import Data.Foldable (traverse_) --type Html = Html.Html ()+type Html = L.Html () -printHtml :: (Lines border) => [[Cell border Html]] -> Html-printHtml table = do-    Html.link_ [Html.rel_ "stylesheet", Html.href_ "hledger.css"]-    Html.style_ Attr.tableStylesheet-    Html.table_ $ traverse_ formatRow table+-- | Export spreadsheet table data as HTML table.+-- This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>+styledTableHtml :: (Lines border) => [[Cell border Html]] -> Html+styledTableHtml table = do+    L.link_ [L.rel_ "stylesheet", L.href_ "hledger.css"]+    L.style_ Attr.tableStylesheet+    L.table_ $ traverse_ formatRow table  formatRow:: (Lines border) => [Cell border Html] -> Html-formatRow = Html.tr_ . traverse_ formatCell+formatRow = L.tr_ . traverse_ formatCell  formatCell :: (Lines border) => Cell border Html -> Html formatCell cell =@@ -38,41 +41,42 @@     let content =             if Text.null $ cellAnchor cell                 then str-                else Html.a_ [Html.href_ $ cellAnchor cell] str in+                else L.a_ [L.href_ $ cellAnchor cell] str in     let style =             case borderStyles cell of                 [] -> []-                ss -> [Html.style_ $ Attr.concatStyles ss] in+                ss -> [L.style_ $ Attr.concatStyles ss] in     let class_ =-            map Html.class_ $+            map L.class_ $             filter (not . Text.null) [Spr.textFromClass $ cellClass cell] in     let span_ makeCell attrs cont =             case Spr.cellSpan cell of                 Spr.NoSpan -> makeCell attrs cont                 Spr.Covered -> pure ()                 Spr.SpanHorizontal n ->-                    makeCell (Html.colspan_ (Text.pack $ show n) : attrs) cont+                    makeCell (L.colspan_ (Text.pack $ show n) : attrs) cont                 Spr.SpanVertical n ->-                    makeCell (Html.rowspan_ (Text.pack $ show n) : attrs) cont+                    makeCell (L.rowspan_ (Text.pack $ show n) : attrs) cont             in     case cellStyle cell of-        Head -> span_ Html.th_ (style++class_) content+        Head -> span_ L.th_ (style++class_) content         Body emph ->             let align =                     case cellType cell of                         TypeString -> []                         TypeDate -> []-                        _ -> [HtmlBase.makeAttribute "align" "right"]+                        _ -> [L.makeAttribute "align" "right"]                 valign =                     case Spr.cellSpan cell of                         Spr.SpanVertical n ->                             if n>1-                                then [HtmlBase.makeAttribute "valign" "top"]+                                then [L.makeAttribute "valign" "top"]                                 else []                         _ -> []                 withEmph =                     case emph of                         Item -> id-                        Total -> Html.b_-            in  span_ Html.td_ (style++align++valign++class_) $+                        Total -> L.b_+            in  span_ L.td_ (style++align++valign++class_) $                 withEmph content+

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           hledger-lib-version:        1.41+version:        1.42 synopsis:       A library providing the core functionality of hledger description:    This library contains hledger's core functionality.                 It is used by most hledger* packages so that they support the same@@ -93,6 +93,7 @@       Hledger.Write.Html.Attribute       Hledger.Write.Html.Blaze       Hledger.Write.Html.Lucid+      Hledger.Write.Html.HtmlCommon       Hledger.Write.Spreadsheet       Hledger.Reports       Hledger.Reports.ReportOptions@@ -140,6 +141,7 @@     , deepseq     , directory >=1.2.6.1     , doclayout >=0.3 && <0.6+    , encoding >=0.10     , extra >=1.6.3     , file-embed >=0.0.10     , filepath@@ -174,7 +176,6 @@   type: exitcode-stdio-1.0   main-is: doctests.hs   hs-source-dirs:-      ./       test   ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind   build-depends:@@ -200,6 +201,7 @@     , directory >=1.2.6.1     , doclayout >=0.3 && <0.6     , doctest >=0.18.1+    , encoding >=0.10     , extra >=1.6.3     , file-embed >=0.0.10     , filepath@@ -236,7 +238,6 @@   type: exitcode-stdio-1.0   main-is: unittest.hs   hs-source-dirs:-      ./       test   ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind   build-depends:@@ -261,6 +262,7 @@     , deepseq     , directory >=1.2.6.1     , doclayout >=0.3 && <0.6+    , encoding >=0.10     , extra >=1.6.3     , file-embed >=0.0.10     , filepath

@@ -2,9 +2,7 @@ Run the hledger-lib package's unit tests using the tasty test runner. -} --- package-qualified import to avoid cabal missing-home-modules warning (and double-building ?)-{-# LANGUAGE PackageImports #-}-import "hledger-lib" Hledger (tests_Hledger)+import Hledger (tests_Hledger) import System.Environment (setEnv) import Test.Tasty (defaultMain)