slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib,cli: Use Text for CSV values.

Browse Source
This commit is contained in:
Stephen Morgan 2020-11-05 18:59:35 +11:00
parent e3ec01c3c6
commit 541c4fc18c
9 changed files with 217 additions and 226 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

302
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -11,17 +11,17 @@ A reader for CSV data, using an extra rules file to help interpret the data.
-- stack haddock hledger-lib --fast --no-haddock-deps --haddock-arguments='--ignore-all-exports' --open -- stack haddock hledger-lib --fast --no-haddock-deps --haddock-arguments='--ignore-all-exports' --open
--- ** language --- ** language
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
--- ** exports --- ** exports
module Hledger.Read.CsvReader ( module Hledger.Read.CsvReader (
@ -52,7 +52,6 @@ import Control.Monad.Trans.Class (lift)
import Data.Char (toLower, isDigit, isSpace, isAlphaNum, isAscii, ord) import Data.Char (toLower, isDigit, isSpace, isAlphaNum, isAscii, ord)
import Data.Bifunctor (first) import Data.Bifunctor (first)
import "base-compat-batteries" Data.List.Compat import "base-compat-batteries" Data.List.Compat
import qualified Data.List.Split as LS (splitOn)
import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.MemoUgly (memo) import Data.MemoUgly (memo)
import Data.Ord (comparing) import Data.Ord (comparing)
@ -61,6 +60,8 @@ import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import Data.Time.Format (parseTimeM, defaultTimeLocale) import Data.Time.Format (parseTimeM, defaultTimeLocale)
import Safe (atMay, headMay, lastMay, readDef, readMay) import Safe (atMay, headMay, lastMay, readDef, readMay)
@ -88,7 +89,7 @@ import Hledger.Read.Common (aliasesFromOpts, Reader(..),InputOpts(..), amountp,
type CSV = [CsvRecord] type CSV = [CsvRecord]
type CsvRecord = [CsvValue] type CsvRecord = [CsvValue]
type CsvValue = String type CsvValue = Text
--- ** reader --- ** reader
@ -164,7 +165,7 @@ defaultRulesText csvfile = T.pack $ unlines
," account2 assets:bank:savings\n" ," account2 assets:bank:savings\n"
] ]
addDirective :: (DirectiveName, String) -> CsvRulesParsed -> CsvRulesParsed addDirective :: (DirectiveName, Text) -> CsvRulesParsed -> CsvRulesParsed
addDirective d r = r{rdirectives=d:rdirectives r} addDirective d r = r{rdirectives=d:rdirectives r}
addAssignment :: (HledgerFieldName, FieldTemplate) -> CsvRulesParsed -> CsvRulesParsed addAssignment :: (HledgerFieldName, FieldTemplate) -> CsvRulesParsed -> CsvRulesParsed
@ -181,7 +182,7 @@ addAssignmentsFromList fs r = foldl' maybeAddAssignment r journalfieldnames
where where
maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs) rules maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs) rules
where where
addAssignmentFromIndex i = addAssignment (f, "%"++show (i+1)) addAssignmentFromIndex i = addAssignment (f, T.pack $ '%':show (i+1))
addConditionalBlock :: ConditionalBlock -> CsvRulesParsed -> CsvRulesParsed addConditionalBlock :: ConditionalBlock -> CsvRulesParsed -> CsvRulesParsed
addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r} addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r}
@ -240,7 +241,7 @@ validateRules rules = do
-- | A set of data definitions and account-matching patterns sufficient to -- | A set of data definitions and account-matching patterns sufficient to
-- convert a particular CSV data file into meaningful journal transactions. -- convert a particular CSV data file into meaningful journal transactions.
data CsvRules' a = CsvRules' { data CsvRules' a = CsvRules' {
rdirectives :: [(DirectiveName,String)], rdirectives :: [(DirectiveName,Text)],
-- ^ top-level rules, as (keyword, value) pairs -- ^ top-level rules, as (keyword, value) pairs
rcsvfieldindexes :: [(CsvFieldName, CsvFieldIndex)], rcsvfieldindexes :: [(CsvFieldName, CsvFieldIndex)],
-- ^ csv field names and their column number, if declared by a fields list -- ^ csv field names and their column number, if declared by a fields list
@ -260,7 +261,7 @@ type CsvRulesParsed = CsvRules' ()
-- | Type used after parsing is done. Directives, assignments and conditional blocks -- | Type used after parsing is done. Directives, assignments and conditional blocks
-- are in the same order as they were in the unput file and rblocksassigning is functional. -- are in the same order as they were in the unput file and rblocksassigning is functional.
-- Ready to be used for CSV record processing -- Ready to be used for CSV record processing
type CsvRules = CsvRules' (String -> [ConditionalBlock]) type CsvRules = CsvRules' (Text -> [ConditionalBlock])
instance Eq CsvRules where instance Eq CsvRules where
r1 == r2 = (rdirectives r1, rcsvfieldindexes r1, rassignments r1) == r1 == r2 = (rdirectives r1, rcsvfieldindexes r1, rassignments r1) ==
@ -277,27 +278,27 @@ instance Show CsvRules where
type CsvRulesParser a = StateT CsvRulesParsed SimpleTextParser a type CsvRulesParser a = StateT CsvRulesParsed SimpleTextParser a
-- | The keyword of a CSV rule - "fields", "skip", "if", etc. -- | The keyword of a CSV rule - "fields", "skip", "if", etc.
type DirectiveName = String type DirectiveName = Text
-- | CSV field name. -- | CSV field name.
type CsvFieldName = String type CsvFieldName = Text
-- | 1-based CSV column number. -- | 1-based CSV column number.
type CsvFieldIndex = Int type CsvFieldIndex = Int
-- | Percent symbol followed by a CSV field name or column number. Eg: %date, %1. -- | Percent symbol followed by a CSV field name or column number. Eg: %date, %1.
type CsvFieldReference = String type CsvFieldReference = Text
-- | One of the standard hledger fields or pseudo-fields that can be assigned to. -- | One of the standard hledger fields or pseudo-fields that can be assigned to.
-- Eg date, account1, amount, amount1-in, date-format. -- Eg date, account1, amount, amount1-in, date-format.
type HledgerFieldName = String type HledgerFieldName = Text
-- | A text value to be assigned to a hledger field, possibly -- | A text value to be assigned to a hledger field, possibly
-- containing csv field references to be interpolated. -- containing csv field references to be interpolated.
type FieldTemplate = String type FieldTemplate = Text
-- | A strptime date parsing pattern, as supported by Data.Time.Format. -- | A strptime date parsing pattern, as supported by Data.Time.Format.
type DateFormat = String type DateFormat = Text
-- | A prefix for a matcher test, either & or none (implicit or). -- | A prefix for a matcher test, either & or none (implicit or).
data MatcherPrefix = And | None data MatcherPrefix = And | None
@ -453,16 +454,16 @@ commentlinep = lift skipNonNewlineSpaces >> commentcharp >> lift restofline >> r
commentcharp :: CsvRulesParser Char commentcharp :: CsvRulesParser Char
commentcharp = oneOf (";#*" :: [Char]) commentcharp = oneOf (";#*" :: [Char])
directivep :: CsvRulesParser (DirectiveName, String) directivep :: CsvRulesParser (DirectiveName, Text)
directivep = (do directivep = (do
lift $ dbgparse 8 "trying directive" lift $ dbgparse 8 "trying directive"
d <- fmap T.unpack $ choiceInState $ map (lift . string . T.pack) directives d <- choiceInState $ map (lift . string) directives
v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp) v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)
<|> (optional (char ':') >> lift skipNonNewlineSpaces >> lift eolof >> return "") <|> (optional (char ':') >> lift skipNonNewlineSpaces >> lift eolof >> return "")
return (d, v) return (d, v)
) <?> "directive" ) <?> "directive"
directives :: [String] directives :: [Text]
directives = directives =
["date-format" ["date-format"
,"decimal-mark" ,"decimal-mark"
@ -474,8 +475,8 @@ directives =
, "balance-type" , "balance-type"
] ]
directivevalp :: CsvRulesParser String directivevalp :: CsvRulesParser Text
directivevalp = anySingle `manyTill` lift eolof directivevalp = T.pack <$> anySingle `manyTill` lift eolof
fieldnamelistp :: CsvRulesParser [CsvFieldName] fieldnamelistp :: CsvRulesParser [CsvFieldName]
fieldnamelistp = (do fieldnamelistp = (do
@ -487,21 +488,18 @@ fieldnamelistp = (do
f <- fromMaybe "" <$> optional fieldnamep f <- fromMaybe "" <$> optional fieldnamep
fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep) fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep)
lift restofline lift restofline
return $ map (map toLower) $ f:fs return . map T.toLower $ f:fs
) <?> "field name list" ) <?> "field name list"
fieldnamep :: CsvRulesParser String fieldnamep :: CsvRulesParser Text
fieldnamep = quotedfieldnamep <|> barefieldnamep fieldnamep = quotedfieldnamep <|> barefieldnamep
quotedfieldnamep :: CsvRulesParser String quotedfieldnamep :: CsvRulesParser Text
quotedfieldnamep = do quotedfieldnamep =
char '"' char '"' *> takeWhile1P Nothing (`notElem` ("\"\n:;#~" :: [Char])) <* char '"'
f <- some $ noneOf ("\"\n:;#~" :: [Char])
char '"'
return f
barefieldnamep :: CsvRulesParser String barefieldnamep :: CsvRulesParser Text
barefieldnamep = some $ noneOf (" \t\n,;#~" :: [Char]) barefieldnamep = takeWhile1P Nothing (`notElem` (" \t\n,;#~" :: [Char]))
fieldassignmentp :: CsvRulesParser (HledgerFieldName, FieldTemplate) fieldassignmentp :: CsvRulesParser (HledgerFieldName, FieldTemplate)
fieldassignmentp = do fieldassignmentp = do
@ -513,10 +511,10 @@ fieldassignmentp = do
return (f,v) return (f,v)
<?> "field assignment" <?> "field assignment"
journalfieldnamep :: CsvRulesParser String journalfieldnamep :: CsvRulesParser Text
journalfieldnamep = do journalfieldnamep = do
lift (dbgparse 8 "trying journalfieldnamep") lift (dbgparse 8 "trying journalfieldnamep")
T.unpack <$> choiceInState (map (lift . string . T.pack) journalfieldnames) choiceInState $ map (lift . string) journalfieldnames
maxpostings = 99 maxpostings = 99
@ -524,14 +522,14 @@ maxpostings = 99
-- Names must precede any other name they contain, for the parser -- Names must precede any other name they contain, for the parser
-- (amount-in before amount; date2 before date). TODO: fix -- (amount-in before amount; date2 before date). TODO: fix
journalfieldnames = journalfieldnames =
concat [[ "account" ++ i concat [[ "account" <> i
,"amount" ++ i ++ "-in" ,"amount" <> i <> "-in"
,"amount" ++ i ++ "-out" ,"amount" <> i <> "-out"
,"amount" ++ i ,"amount" <> i
,"balance" ++ i ,"balance" <> i
,"comment" ++ i ,"comment" <> i
,"currency" ++ i ,"currency" <> i
] | x <- [maxpostings, (maxpostings-1)..1], let i = show x] ] | x <- [maxpostings, (maxpostings-1)..1], let i = T.pack $ show x]
++ ++
["amount-in" ["amount-in"
,"amount-out" ,"amount-out"
@ -556,10 +554,10 @@ assignmentseparatorp = do
] ]
return () return ()
fieldvalp :: CsvRulesParser String fieldvalp :: CsvRulesParser Text
fieldvalp = do fieldvalp = do
lift $ dbgparse 8 "trying fieldvalp" lift $ dbgparse 8 "trying fieldvalp"
anySingle `manyTill` lift eolof T.pack <$> anySingle `manyTill` lift eolof
-- A conditional block: one or more matchers, one per line, followed by one or more indented rules. -- A conditional block: one or more matchers, one per line, followed by one or more indented rules.
conditionalblockp :: CsvRulesParser ConditionalBlock conditionalblockp :: CsvRulesParser ConditionalBlock
@ -587,14 +585,14 @@ conditionaltablep :: CsvRulesParser [ConditionalBlock]
conditionaltablep = do conditionaltablep = do
lift $ dbgparse 8 "trying conditionaltablep" lift $ dbgparse 8 "trying conditionaltablep"
start <- getOffset start <- getOffset
string "if" string "if"
sep <- lift $ satisfy (\c -> not (isAlphaNum c || isSpace c)) sep <- lift $ satisfy (\c -> not (isAlphaNum c || isSpace c))
fields <- journalfieldnamep `sepBy1` (char sep) fields <- journalfieldnamep `sepBy1` (char sep)
newline newline
body <- flip manyTill (lift eolof) $ do body <- flip manyTill (lift eolof) $ do
off <- getOffset off <- getOffset
m <- matcherp' (char sep >> return ()) m <- matcherp' (char sep >> return ())
vs <- LS.splitOn [sep] <$> lift restofline vs <- T.split (==sep) . T.pack <$> lift restofline
if (length vs /= length fields) if (length vs /= length fields)
then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d\n" (length fields) (length vs)) :: String) then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d\n" (length fields) (length vs)) :: String)
else return (m,vs) else return (m,vs)
@ -655,8 +653,8 @@ csvfieldreferencep :: CsvRulesParser CsvFieldReference
csvfieldreferencep = do csvfieldreferencep = do
lift $ dbgparse 8 "trying csvfieldreferencep" lift $ dbgparse 8 "trying csvfieldreferencep"
char '%' char '%'
f <- fieldnamep f <- T.unpack <$> fieldnamep -- XXX unpack and then pack
return $ '%' : quoteIfNeeded f return . T.pack $ '%' : quoteIfNeeded f
-- A single regular expression -- A single regular expression
regexp :: CsvRulesParser () -> CsvRulesParser Regexp regexp :: CsvRulesParser () -> CsvRulesParser Regexp
@ -721,7 +719,7 @@ readJournalFromCsv mrulesfile csvfile csvdata =
let skiplines = case getDirective "skip" rules of let skiplines = case getDirective "skip" rules of
Nothing -> 0 Nothing -> 0
Just "" -> 1 Just "" -> 1
Just s -> readDef (throwerr $ "could not parse skip value: " ++ show s) s Just s -> readDef (throwerr $ "could not parse skip value: " ++ show s) $ T.unpack s
-- parse csv -- parse csv
let let
@ -785,12 +783,11 @@ readJournalFromCsv mrulesfile csvfile csvdata =
-- | Parse special separator names TAB and SPACE, or return the first -- | Parse special separator names TAB and SPACE, or return the first
-- character. Return Nothing on empty string -- character. Return Nothing on empty string
parseSeparator :: String -> Maybe Char parseSeparator :: Text -> Maybe Char
parseSeparator = specials . map toLower parseSeparator = specials . T.toLower
where specials "space" = Just ' ' where specials "space" = Just ' '
specials "tab" = Just '\t' specials "tab" = Just '\t'
specials (x:_) = Just x specials xs = fst <$> T.uncons xs
specials [] = Nothing
parseCsv :: Char -> FilePath -> Text -> IO (Either String CSV) parseCsv :: Char -> FilePath -> Text -> IO (Either String CSV)
parseCsv separator filePath csvdata = parseCsv separator filePath csvdata =
@ -813,15 +810,13 @@ parseResultToCsv :: (Foldable t, Functor t) => t (t B.ByteString) -> CSV
parseResultToCsv = toListList . unpackFields parseResultToCsv = toListList . unpackFields
where where
toListList = toList . fmap toList toListList = toList . fmap toList
unpackFields = (fmap . fmap) (T.unpack . T.decodeUtf8) unpackFields = (fmap . fmap) T.decodeUtf8
printCSV :: CSV -> String printCSV :: CSV -> TL.Text
printCSV records = unlined (printRecord `map` records) printCSV = TB.toLazyText . unlined . map printRecord
where printRecord = concat . intersperse "," . map printField where printRecord = mconcat . map TB.fromText . intersperse "," . map printField
printField f = "\"" ++ concatMap escape f ++ "\"" printField = wrap "\"" "\"" . T.replace "\"" "\\\"\\\""
escape '"' = "\"\"" unlined = (<> TB.fromText "\n") . mconcat . intersperse "\n"
escape x = [x]
unlined = concat . intersperse "\n"
-- | Return the cleaned up and validated CSV data (can be empty), or an error. -- | Return the cleaned up and validated CSV data (can be empty), or an error.
validateCsv :: CsvRules -> Int -> Either String CSV -> Either String [CsvRecord] validateCsv :: CsvRules -> Int -> Either String CSV -> Either String [CsvRecord]
@ -834,7 +829,7 @@ validateCsv rules numhdrlines (Right rs) = validate $ applyConditionalSkips $ dr
(Nothing, Nothing) -> Nothing (Nothing, Nothing) -> Nothing
(Just _, _) -> Just maxBound (Just _, _) -> Just maxBound
(Nothing, Just "") -> Just 1 (Nothing, Just "") -> Just 1
(Nothing, Just x) -> Just (read x) (Nothing, Just x) -> Just (read $ T.unpack x)
applyConditionalSkips [] = [] applyConditionalSkips [] = []
applyConditionalSkips (r:rest) = applyConditionalSkips (r:rest) =
case skipCount r of case skipCount r of
@ -866,7 +861,7 @@ validateCsv rules numhdrlines (Right rs) = validate $ applyConditionalSkips $ dr
--- ** converting csv records to transactions --- ** converting csv records to transactions
showRules rules record = showRules rules record =
unlines $ catMaybes [ (("the "++fld++" rule is: ")++) <$> getEffectiveAssignment rules record fld | fld <- journalfieldnames] T.unlines $ catMaybes [ (("the "<>fld<>" rule is: ")<>) <$> getEffectiveAssignment rules record fld | fld <- journalfieldnames]
-- | Look up the value (template) of a csv rule by rule keyword. -- | Look up the value (template) of a csv rule by rule keyword.
csvRule :: CsvRules -> DirectiveName -> Maybe FieldTemplate csvRule :: CsvRules -> DirectiveName -> Maybe FieldTemplate
@ -880,7 +875,7 @@ hledgerField = getEffectiveAssignment
-- | Look up the final value assigned to a hledger field, with csv field -- | Look up the final value assigned to a hledger field, with csv field
-- references interpolated. -- references interpolated.
hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe String hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe Text
hledgerFieldValue rules record = fmap (renderTemplate rules record) . hledgerField rules record hledgerFieldValue rules record = fmap (renderTemplate rules record) . hledgerField rules record
transactionFromCsvRecord :: SourcePos -> CsvRules -> CsvRecord -> Transaction transactionFromCsvRecord :: SourcePos -> CsvRules -> CsvRecord -> Transaction
@ -892,18 +887,18 @@ transactionFromCsvRecord sourcepos rules record = t
rule = csvRule rules :: DirectiveName -> Maybe FieldTemplate rule = csvRule rules :: DirectiveName -> Maybe FieldTemplate
-- ruleval = csvRuleValue rules record :: DirectiveName -> Maybe String -- ruleval = csvRuleValue rules record :: DirectiveName -> Maybe String
field = hledgerField rules record :: HledgerFieldName -> Maybe FieldTemplate field = hledgerField rules record :: HledgerFieldName -> Maybe FieldTemplate
fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe String fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text
parsedate = parseDateWithCustomOrDefaultFormats (rule "date-format") parsedate = parseDateWithCustomOrDefaultFormats (rule "date-format")
mkdateerror datefield datevalue mdateformat = unlines mkdateerror datefield datevalue mdateformat = T.unpack $ T.unlines
["error: could not parse \""++datevalue++"\" as a date using date format " ["error: could not parse \""<>datevalue<>"\" as a date using date format "
++maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" show mdateformat <>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat
,showRecord record ,showRecord record
,"the "++datefield++" rule is: "++(fromMaybe "required, but missing" $ field datefield) ,"the "<>datefield<>" rule is: "<>(fromMaybe "required, but missing" $ field datefield)
,"the date-format is: "++fromMaybe "unspecified" mdateformat ,"the date-format is: "<>fromMaybe "unspecified" mdateformat
,"you may need to " ,"you may need to "
++"change your "++datefield++" rule, " <>"change your "<>datefield<>" rule, "
++maybe "add a" (const "change your") mdateformat++" date-format rule, " <>maybe "add a" (const "change your") mdateformat<>" date-format rule, "
++"or "++maybe "add a" (const "change your") mskip++" skip rule" <>"or "<>maybe "add a" (const "change your") mskip<>" skip rule"
,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y" ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y"
] ]
where where
@ -923,10 +918,10 @@ transactionFromCsvRecord sourcepos rules record = t
status = status =
case fieldval "status" of case fieldval "status" of
Nothing -> Unmarked Nothing -> Unmarked
Just s -> either statuserror id $ runParser (statusp <* eof) "" $ T.pack s Just s -> either statuserror id $ runParser (statusp <* eof) "" s
where where
statuserror err = error' $ unlines statuserror err = error' $ unlines
["error: could not parse \""++s++"\" as a cleared status (should be *, ! or empty)" ["error: could not parse \""<>T.unpack s<>"\" as a cleared status (should be *, ! or empty)"
,"the parse error is: "++customErrorBundlePretty err ,"the parse error is: "++customErrorBundlePretty err
] ]
code = maybe "" singleline $ fieldval "code" code = maybe "" singleline $ fieldval "code"
@ -934,14 +929,16 @@ transactionFromCsvRecord sourcepos rules record = t
comment = maybe "" singleline $ fieldval "comment" comment = maybe "" singleline $ fieldval "comment"
precomment = maybe "" singleline $ fieldval "precomment" precomment = maybe "" singleline $ fieldval "precomment"
singleline = T.unwords . filter (not . T.null) . map T.strip . T.lines
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- 3. Generate the postings for which an account has been assigned -- 3. Generate the postings for which an account has been assigned
-- (possibly indirectly due to an amount or balance assignment) -- (possibly indirectly due to an amount or balance assignment)
p1IsVirtual = (accountNamePostingType . T.pack <$> fieldval "account1") == Just VirtualPosting p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting
ps = [p | n <- [1..maxpostings] ps = [p | n <- [1..maxpostings]
,let comment = T.pack $ fromMaybe "" $ fieldval ("comment"++show n) ,let comment = fromMaybe "" $ fieldval ("comment"<> T.pack (show n))
,let currency = fromMaybe "" (fieldval ("currency"++show n) <|> fieldval "currency") ,let currency = fromMaybe "" (fieldval ("currency"<> T.pack (show n)) <|> fieldval "currency")
,let mamount = getAmount rules record currency p1IsVirtual n ,let mamount = getAmount rules record currency p1IsVirtual n
,let mbalance = getBalance rules record currency n ,let mbalance = getBalance rules record currency n
,Just (acct,isfinal) <- [getAccount rules record mamount mbalance n] -- skips Nothings ,Just (acct,isfinal) <- [getAccount rules record mamount mbalance n] -- skips Nothings
@ -965,10 +962,10 @@ transactionFromCsvRecord sourcepos rules record = t
,tdate = date' ,tdate = date'
,tdate2 = mdate2' ,tdate2 = mdate2'
,tstatus = status ,tstatus = status
,tcode = T.pack code ,tcode = code
,tdescription = T.pack description ,tdescription = description
,tcomment = T.pack comment ,tcomment = comment
,tprecedingcomment = T.pack precomment ,tprecedingcomment = precomment
,tpostings = ps ,tpostings = ps
} }
@ -979,7 +976,7 @@ transactionFromCsvRecord sourcepos rules record = t
-- For postings 1 or 2 it also looks at "amount", "amount-in", "amount-out". -- For postings 1 or 2 it also looks at "amount", "amount-in", "amount-out".
-- If more than one of these has a value, it looks for one that is non-zero. -- If more than one of these has a value, it looks for one that is non-zero.
-- If there's multiple non-zeros, or no non-zeros but multiple zeros, it throws an error. -- If there's multiple non-zeros, or no non-zeros but multiple zeros, it throws an error.
getAmount :: CsvRules -> CsvRecord -> String -> Bool -> Int -> Maybe MixedAmount getAmount :: CsvRules -> CsvRecord -> Text -> Bool -> Int -> Maybe MixedAmount
getAmount rules record currency p1IsVirtual n = getAmount rules record currency p1IsVirtual n =
-- Warning, many tricky corner cases here. -- Warning, many tricky corner cases here.
-- docs: hledger_csv.m4.md #### amount -- docs: hledger_csv.m4.md #### amount
@ -988,14 +985,15 @@ getAmount rules record currency p1IsVirtual n =
unnumberedfieldnames = ["amount","amount-in","amount-out"] unnumberedfieldnames = ["amount","amount-in","amount-out"]
-- amount field names which can affect this posting -- amount field names which can affect this posting
fieldnames = map (("amount"++show n)++) ["","-in","-out"] fieldnames = map (("amount"<> T.pack(show n))<>) ["","-in","-out"]
-- For posting 1, also recognise the old amount/amount-in/amount-out names. -- For posting 1, also recognise the old amount/amount-in/amount-out names.
-- For posting 2, the same but only if posting 1 needs balancing. -- For posting 2, the same but only if posting 1 needs balancing.
++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else [] ++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else []
-- assignments to any of these field names with non-empty values -- assignments to any of these field names with non-empty values
assignments = [(f,a') | f <- fieldnames assignments = [(f,a') | f <- fieldnames
, Just v@(_:_) <- [strip . renderTemplate rules record <$> hledgerField rules record f] , Just v <- [T.strip . renderTemplate rules record <$> hledgerField rules record f]
, not $ T.null v
, let a = parseAmount rules record currency v , let a = parseAmount rules record currency v
-- With amount/amount-in/amount-out, in posting 2, -- With amount/amount-in/amount-out, in posting 2,
-- flip the sign and convert to cost, as they did before 1.17 -- flip the sign and convert to cost, as they did before 1.17
@ -1006,7 +1004,7 @@ getAmount rules record currency p1IsVirtual n =
assignments' | any isnumbered assignments = filter isnumbered assignments assignments' | any isnumbered assignments = filter isnumbered assignments
| otherwise = assignments | otherwise = assignments
where where
isnumbered (f,_) = any (flip elem ['0'..'9']) f isnumbered (f,_) = T.any (flip elem ['0'..'9']) f
-- if there's more than one value and only some are zeros, discard the zeros -- if there's more than one value and only some are zeros, discard the zeros
assignments'' assignments''
@ -1017,24 +1015,24 @@ getAmount rules record currency p1IsVirtual n =
in case -- dbg0 ("amounts for posting "++show n) in case -- dbg0 ("amounts for posting "++show n)
assignments'' of assignments'' of
[] -> Nothing [] -> Nothing
[(f,a)] | "-out" `isSuffixOf` f -> Just (-a) -- for -out fields, flip the sign [(f,a)] | "-out" `T.isSuffixOf` f -> Just (-a) -- for -out fields, flip the sign
[(_,a)] -> Just a [(_,a)] -> Just a
fs -> error' $ unlines $ [ -- PARTIAL: fs -> error' . T.unpack . T.unlines $ [ -- PARTIAL:
"multiple non-zero amounts or multiple zero amounts assigned," "multiple non-zero amounts or multiple zero amounts assigned,"
,"please ensure just one. (https://hledger.org/csv.html#amount)" ,"please ensure just one. (https://hledger.org/csv.html#amount)"
," " ++ showRecord record ," " <> showRecord record
," for posting: " ++ show n ," for posting: " <> T.pack (show n)
] ]
++ [" assignment: " ++ f ++ " " ++ ++ [" assignment: " <> f <> " " <>
fromMaybe "" (hledgerField rules record f) ++ fromMaybe "" (hledgerField rules record f) <>
"\t=> value: " ++ showMixedAmount a -- XXX not sure this is showing all the right info "\t=> value: " <> T.pack (showMixedAmount a) -- XXX not sure this is showing all the right info
| (f,a) <- fs] | (f,a) <- fs]
-- | Figure out the expected balance (assertion or assignment) specified for posting N, -- | Figure out the expected balance (assertion or assignment) specified for posting N,
-- if any (and its parse position). -- if any (and its parse position).
getBalance :: CsvRules -> CsvRecord -> String -> Int -> Maybe (Amount, GenericSourcePos) getBalance :: CsvRules -> CsvRecord -> Text -> Int -> Maybe (Amount, GenericSourcePos)
getBalance rules record currency n = do getBalance rules record currency n = do
v <- (fieldval ("balance"++show n) v <- (fieldval ("balance"<> T.pack (show n))
-- for posting 1, also recognise the old field name -- for posting 1, also recognise the old field name
<|> if n==1 then fieldval "balance" else Nothing) <|> if n==1 then fieldval "balance" else Nothing)
case v of case v of
@ -1043,30 +1041,29 @@ getBalance rules record currency n = do
parseBalanceAmount rules record currency n s parseBalanceAmount rules record currency n s
,nullsourcepos -- parse position to show when assertion fails, ,nullsourcepos -- parse position to show when assertion fails,
) -- XXX the csv record's line number would be good ) -- XXX the csv record's line number would be good
where where
fieldval = fmap strip . hledgerFieldValue rules record :: HledgerFieldName -> Maybe String fieldval = fmap T.strip . hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text
-- | Given a non-empty amount string (from CSV) to parse, along with a -- | Given a non-empty amount string (from CSV) to parse, along with a
-- possibly non-empty currency symbol to prepend, -- possibly non-empty currency symbol to prepend,
-- parse as a hledger MixedAmount (as in journal format), or raise an error. -- parse as a hledger MixedAmount (as in journal format), or raise an error.
-- The whole CSV record is provided for the error message. -- The whole CSV record is provided for the error message.
parseAmount :: CsvRules -> CsvRecord -> String -> String -> MixedAmount parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount
parseAmount rules record currency s = parseAmount rules record currency s =
either mkerror (Mixed . (:[])) $ -- PARTIAL: either mkerror (Mixed . (:[])) $ -- PARTIAL:
runParser (evalStateT (amountp <* eof) journalparsestate) "" $ runParser (evalStateT (amountp <* eof) journalparsestate) "" $
T.pack $ (currency++) $ simplifySign s currency <> simplifySign s
where where
journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules} journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}
mkerror e = error' $ unlines mkerror e = error' . T.unpack $ T.unlines
["error: could not parse \""++s++"\" as an amount" ["error: could not parse \"" <> s <> "\" as an amount"
,showRecord record ,showRecord record
,showRules rules record ,showRules rules record
-- ,"the default-currency is: "++fromMaybe "unspecified" (getDirective "default-currency" rules) -- ,"the default-currency is: "++fromMaybe "unspecified" (getDirective "default-currency" rules)
,"the parse error is: "++customErrorBundlePretty e ,"the parse error is: " <> T.pack (customErrorBundlePretty e)
,"you may need to " ,"you may need to \
++"change your amount*, balance*, or currency* rules, " \change your amount*, balance*, or currency* rules, \
++"or add or change your skip rule" \or add or change your skip rule"
] ]
-- XXX unify these ^v -- XXX unify these ^v
@ -1076,30 +1073,30 @@ parseAmount rules record currency s =
-- possibly non-empty currency symbol to prepend, -- possibly non-empty currency symbol to prepend,
-- parse as a hledger Amount (as in journal format), or raise an error. -- parse as a hledger Amount (as in journal format), or raise an error.
-- The CSV record and the field's numeric suffix are provided for the error message. -- The CSV record and the field's numeric suffix are provided for the error message.
parseBalanceAmount :: CsvRules -> CsvRecord -> String -> Int -> String -> Amount parseBalanceAmount :: CsvRules -> CsvRecord -> Text -> Int -> Text -> Amount
parseBalanceAmount rules record currency n s = parseBalanceAmount rules record currency n s =
either (mkerror n s) id $ either (mkerror n s) id $
runParser (evalStateT (amountp <* eof) journalparsestate) "" $ runParser (evalStateT (amountp <* eof) journalparsestate) "" $
T.pack $ (currency++) $ simplifySign s currency <> simplifySign s
-- the csv record's line number would be good -- the csv record's line number would be good
where where
journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules} journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}
mkerror n s e = error' $ unlines mkerror n s e = error' . T.unpack $ T.unlines
["error: could not parse \""++s++"\" as balance"++show n++" amount" ["error: could not parse \"" <> s <> "\" as balance"<> T.pack (show n) <> " amount"
,showRecord record ,showRecord record
,showRules rules record ,showRules rules record
-- ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency -- ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency
,"the parse error is: "++customErrorBundlePretty e ,"the parse error is: "<> T.pack (customErrorBundlePretty e)
] ]
-- Read a valid decimal mark from the decimal-mark rule, if any. -- Read a valid decimal mark from the decimal-mark rule, if any.
-- If the rule is present with an invalid argument, raise an error. -- If the rule is present with an invalid argument, raise an error.
parseDecimalMark :: CsvRules -> Maybe DecimalMark parseDecimalMark :: CsvRules -> Maybe DecimalMark
parseDecimalMark rules = parseDecimalMark rules = do
case rules `csvRule` "decimal-mark" of s <- rules `csvRule` "decimal-mark"
Nothing -> Nothing case T.uncons s of
Just [c] | isDecimalMark c -> Just c Just (c, rest) | T.null rest && isDecimalMark c -> return c
Just s -> error' $ "decimal-mark's argument should be \".\" or \",\" (not \""++s++"\")" _ -> error' . T.unpack $ "decimal-mark's argument should be \".\" or \",\" (not \""<>s<>"\")"
-- | Make a balance assertion for the given amount, with the given parse -- | Make a balance assertion for the given amount, with the given parse
-- position (to be shown in assertion failures), with the assertion type -- position (to be shown in assertion failures), with the assertion type
@ -1116,8 +1113,8 @@ mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos}
Just "==" -> nullassertion{batotal=True} Just "==" -> nullassertion{batotal=True}
Just "=*" -> nullassertion{bainclusive=True} Just "=*" -> nullassertion{bainclusive=True}
Just "==*" -> nullassertion{batotal=True, bainclusive=True} Just "==*" -> nullassertion{batotal=True, bainclusive=True}
Just x -> error' $ unlines -- PARTIAL: Just x -> error' . T.unpack $ T.unlines -- PARTIAL:
[ "balance-type \"" ++ x ++"\" is invalid. Use =, ==, =* or ==*." [ "balance-type \"" <> x <>"\" is invalid. Use =, ==, =* or ==*."
, showRecord record , showRecord record
, showRules rules record , showRules rules record
] ]
@ -1128,8 +1125,8 @@ mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos}
getAccount :: CsvRules -> CsvRecord -> Maybe MixedAmount -> Maybe (Amount, GenericSourcePos) -> Int -> Maybe (AccountName, Bool) getAccount :: CsvRules -> CsvRecord -> Maybe MixedAmount -> Maybe (Amount, GenericSourcePos) -> Int -> Maybe (AccountName, Bool)
getAccount rules record mamount mbalance n = getAccount rules record mamount mbalance n =
let let
fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe String fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text
maccount = T.pack <$> fieldval ("account"++show n) maccount = fieldval ("account"<> T.pack (show n))
in case maccount of in case maccount of
-- accountN is set to the empty string - no posting will be generated -- accountN is set to the empty string - no posting will be generated
Just "" -> Nothing Just "" -> Nothing
@ -1150,7 +1147,7 @@ getAccount rules record mamount mbalance n =
unknownExpenseAccount = "expenses:unknown" unknownExpenseAccount = "expenses:unknown"
unknownIncomeAccount = "income:unknown" unknownIncomeAccount = "income:unknown"
type CsvAmountString = String type CsvAmountString = Text
-- | Canonicalise the sign in a CSV amount string. -- | Canonicalise the sign in a CSV amount string.
-- Such strings can have a minus sign, negating parentheses, -- Such strings can have a minus sign, negating parentheses,
@ -1171,18 +1168,20 @@ type CsvAmountString = String
-- >>> simplifySign "((1))" -- >>> simplifySign "((1))"
-- "1" -- "1"
simplifySign :: CsvAmountString -> CsvAmountString simplifySign :: CsvAmountString -> CsvAmountString
simplifySign ('(':s) | lastMay s == Just ')' = simplifySign $ negateStr $ init s simplifySign amtstr
simplifySign ('-':'(':s) | lastMay s == Just ')' = simplifySign $ init s | Just ('(',t) <- T.uncons amtstr, Just (amt,')') <- T.unsnoc t = simplifySign $ negateStr amt
simplifySign ('-':'-':s) = s | Just ('-',b) <- T.uncons amtstr, Just ('(',t) <- T.uncons b, Just (amt,')') <- T.unsnoc t = simplifySign amt
simplifySign s = s | Just ('-',m) <- T.uncons amtstr, Just ('-',amt) <- T.uncons m = amt
| otherwise = amtstr
negateStr :: String -> String negateStr :: Text -> Text
negateStr ('-':s) = s negateStr amtstr = case T.uncons amtstr of
negateStr s = '-':s Just ('-',s) -> s
_ -> T.cons '-' amtstr
-- | Show a (approximate) recreation of the original CSV record. -- | Show a (approximate) recreation of the original CSV record.
showRecord :: CsvRecord -> String showRecord :: CsvRecord -> Text
showRecord r = "record values: "++intercalate "," (map show r) showRecord r = "record values: "<>T.intercalate "," (map (wrap "\"" "\"") r)
-- | Given the conversion rules, a CSV record and a hledger field name, find -- | Given the conversion rules, a CSV record and a hledger field name, find
-- the value template ultimately assigned to this field, if any, by a field -- the value template ultimately assigned to this field, if any, by a field
@ -1217,47 +1216,48 @@ getEffectiveAssignment rules record f = lastMay $ map snd $ assignments
-- - any quotes enclosing field values are removed -- - any quotes enclosing field values are removed
-- - and the field separator is always comma -- - and the field separator is always comma
-- which means that a field containing a comma will look like two fields. -- which means that a field containing a comma will look like two fields.
wholecsvline = dbg7 "wholecsvline" $ intercalate "," record wholecsvline = dbg7 "wholecsvline" . T.unpack $ T.intercalate "," record
matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatch pat csvfieldvalue matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatch pat $ T.unpack csvfieldvalue
where where
-- the value of the referenced CSV field to match against. -- the value of the referenced CSV field to match against.
csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref
-- | Render a field assignment's template, possibly interpolating referenced -- | Render a field assignment's template, possibly interpolating referenced
-- CSV field values. Outer whitespace is removed from interpolated values. -- CSV field values. Outer whitespace is removed from interpolated values.
renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> String renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> Text
renderTemplate rules record t = maybe t concat $ parseMaybe renderTemplate rules record t = maybe t mconcat $ parseMaybe
(many $ takeWhile1P Nothing (/='%') (many $ takeWhile1P Nothing (/='%')
<|> replaceCsvFieldReference rules record <$> referencep) <|> replaceCsvFieldReference rules record <$> referencep)
t t
where where
referencep = liftA2 (:) (char '%') (takeWhile1P (Just "reference") isDescriptorChar) :: Parsec CustomErr String String referencep = liftA2 T.cons (char '%') (takeWhile1P (Just "reference") isDescriptorChar) :: Parsec CustomErr Text Text
isDescriptorChar c = isAscii c && (isAlphaNum c || c == '_' || c == '-') isDescriptorChar c = isAscii c && (isAlphaNum c || c == '_' || c == '-')
-- | Replace something that looks like a reference to a csv field ("%date" or "%1) -- | Replace something that looks like a reference to a csv field ("%date" or "%1)
-- with that field's value. If it doesn't look like a field reference, or if we -- with that field's value. If it doesn't look like a field reference, or if we
-- can't find such a field, leave it unchanged. -- can't find such a field, leave it unchanged.
replaceCsvFieldReference :: CsvRules -> CsvRecord -> CsvFieldReference -> String replaceCsvFieldReference :: CsvRules -> CsvRecord -> CsvFieldReference -> Text
replaceCsvFieldReference rules record s@('%':fieldname) = fromMaybe s $ csvFieldValue rules record fieldname replaceCsvFieldReference rules record s = case T.uncons s of
replaceCsvFieldReference _ _ s = s Just ('%', fieldname) -> fromMaybe s $ csvFieldValue rules record fieldname
_ -> s
-- | Get the (whitespace-stripped) value of a CSV field, identified by its name or -- | Get the (whitespace-stripped) value of a CSV field, identified by its name or
-- column number, ("date" or "1"), from the given CSV record, if such a field exists. -- column number, ("date" or "1"), from the given CSV record, if such a field exists.
csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe String csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe Text
csvFieldValue rules record fieldname = do csvFieldValue rules record fieldname = do
fieldindex <- if | all isDigit fieldname -> readMay fieldname fieldindex <- if | T.all isDigit fieldname -> readMay $ T.unpack fieldname
| otherwise -> lookup (map toLower fieldname) $ rcsvfieldindexes rules | otherwise -> lookup (T.toLower fieldname) $ rcsvfieldindexes rules
fieldvalue <- strip <$> atMay record (fieldindex-1) fieldvalue <- T.strip <$> atMay record (fieldindex-1)
return fieldvalue return fieldvalue
-- | Parse the date string using the specified date-format, or if unspecified -- | Parse the date string using the specified date-format, or if unspecified
-- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading -- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading
-- zeroes optional). -- zeroes optional).
parseDateWithCustomOrDefaultFormats :: Maybe DateFormat -> String -> Maybe Day parseDateWithCustomOrDefaultFormats :: Maybe DateFormat -> Text -> Maybe Day
parseDateWithCustomOrDefaultFormats mformat s = asum $ map parsewith formats parseDateWithCustomOrDefaultFormats mformat s = asum $ map parsewith formats
where where
parsewith = flip (parseTimeM True defaultTimeLocale) s parsewith = flip (parseTimeM True defaultTimeLocale) (T.unpack s)
formats = maybe formats = map T.unpack $ maybe
["%Y/%-m/%-d" ["%Y/%-m/%-d"
,"%Y-%-m-%-d" ,"%Y-%-m-%-d"
,"%Y.%-m.%-d" ,"%Y.%-m.%-d"

6
hledger-lib/Hledger/Reports/BudgetReport.hs
View File

@ -351,13 +351,13 @@ budgetReportAsCsv
-- heading row -- heading row
("Account" : ("Account" :
concatMap (\span -> [T.unpack $ showDateSpan span, "budget"]) colspans concatMap (\span -> [showDateSpan span, "budget"]) colspans
++ concat [["Total" ,"budget"] | row_total_] ++ concat [["Total" ,"budget"] | row_total_]
++ concat [["Average","budget"] | average_] ++ concat [["Average","budget"] | average_]
) : ) :
-- account rows -- account rows
[T.unpack (displayFull a) : [displayFull a :
map showmamt (flattentuples abamts) map showmamt (flattentuples abamts)
++ concat [[showmamt mactualrowtot, showmamt mbudgetrowtot] | row_total_] ++ concat [[showmamt mactualrowtot, showmamt mbudgetrowtot] | row_total_]
++ concat [[showmamt mactualrowavg, showmamt mbudgetrowavg] | average_] ++ concat [[showmamt mactualrowavg, showmamt mbudgetrowavg] | average_]
@ -377,7 +377,7 @@ budgetReportAsCsv
where where
flattentuples abs = concat [[a,b] | (a,b) <- abs] flattentuples abs = concat [[a,b] | (a,b) <- abs]
showmamt = maybe "" (showMixedAmountOneLineWithoutPrice False) showmamt = maybe "" (T.pack . showMixedAmountOneLineWithoutPrice False)
-- tests -- tests

5
hledger-lib/hledger-lib.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 1.12 cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.33.0. -- This file has been generated from package.yaml by hpack version 0.34.2.
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
@ -125,7 +125,6 @@ library
, pretty-simple >4 && <5 , pretty-simple >4 && <5
, regex-tdfa , regex-tdfa
, safe >=0.2 , safe >=0.2
, split >=0.1
, tabular >=0.2 , tabular >=0.2
, tasty >=1.2.3 , tasty >=1.2.3
, tasty-hunit >=0.10.0.2 , tasty-hunit >=0.10.0.2
@ -176,7 +175,6 @@ test-suite doctest
, pretty-simple >4 && <5 , pretty-simple >4 && <5
, regex-tdfa , regex-tdfa
, safe >=0.2 , safe >=0.2
, split >=0.1
, tabular >=0.2 , tabular >=0.2
, tasty >=1.2.3 , tasty >=1.2.3
, tasty-hunit >=0.10.0.2 , tasty-hunit >=0.10.0.2
@ -229,7 +227,6 @@ test-suite unittest
, pretty-simple >4 && <5 , pretty-simple >4 && <5
, regex-tdfa , regex-tdfa
, safe >=0.2 , safe >=0.2
, split >=0.1
, tabular >=0.2 , tabular >=0.2
, tasty >=1.2.3 , tasty >=1.2.3
, tasty-hunit >=0.10.0.2 , tasty-hunit >=0.10.0.2

1
hledger-lib/package.yaml
View File

@ -58,7 +58,6 @@ dependencies:
- pretty-simple >4 && <5 - pretty-simple >4 && <5
- regex-tdfa - regex-tdfa
- safe >=0.2 - safe >=0.2
- split >=0.1
- tabular >=0.2 - tabular >=0.2
- tasty >=1.2.3 - tasty >=1.2.3
- tasty-hunit >=0.10.0.2 - tasty-hunit >=0.10.0.2

14
hledger/Hledger/Cli/Commands/Aregister.hs
View File

@ -113,7 +113,7 @@ aregister opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
reverse items reverse items
-- select renderer -- select renderer
render | fmt=="txt" = accountTransactionsReportAsText opts reportq thisacctq render | fmt=="txt" = accountTransactionsReportAsText opts reportq thisacctq
| fmt=="csv" = TL.pack . printCSV . accountTransactionsReportAsCsv reportq thisacctq | fmt=="csv" = printCSV . accountTransactionsReportAsCsv reportq thisacctq
| fmt=="json" = toJsonText | fmt=="json" = toJsonText
| otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL: | otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL:
where where
@ -130,14 +130,12 @@ accountTransactionsReportItemAsCsvRecord :: Query -> Query -> AccountTransaction
accountTransactionsReportItemAsCsvRecord accountTransactionsReportItemAsCsvRecord
reportq thisacctq reportq thisacctq
(t@Transaction{tindex,tcode,tdescription}, _, _issplit, otheracctsstr, change, balance) (t@Transaction{tindex,tcode,tdescription}, _, _issplit, otheracctsstr, change, balance)
= [idx,date,code,desc,T.unpack otheracctsstr,amt,bal] = [idx,date,tcode,tdescription,otheracctsstr,amt,bal]
where where
idx = show tindex idx = T.pack $ show tindex
date = T.unpack . showDate $ transactionRegisterDate reportq thisacctq t date = showDate $ transactionRegisterDate reportq thisacctq t
code = T.unpack tcode amt = T.pack $ showMixedAmountOneLineWithoutPrice False change
desc = T.unpack tdescription bal = T.pack $ showMixedAmountOneLineWithoutPrice False balance
amt = showMixedAmountOneLineWithoutPrice False change
bal = showMixedAmountOneLineWithoutPrice False balance
-- | Render a register report as plain text suitable for console output. -- | Render a register report as plain text suitable for console output.
accountTransactionsReportAsText :: CliOpts -> Query -> Query -> AccountTransactionsReport -> TL.Text accountTransactionsReportAsText :: CliOpts -> Query -> Query -> AccountTransactionsReport -> TL.Text

42
hledger/Hledger/Cli/Commands/Balance.hs
View File

@ -321,8 +321,8 @@ balance opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
assrt = not $ ignore_assertions_ $ inputopts_ opts assrt = not $ ignore_assertions_ $ inputopts_ opts
render = case fmt of render = case fmt of
"txt" -> budgetReportAsText ropts "txt" -> budgetReportAsText ropts
"json" -> (++"\n") . TL.unpack . toJsonText "json" -> TL.unpack . (<>"\n") . toJsonText
"csv" -> (++"\n") . printCSV . budgetReportAsCsv ropts "csv" -> TL.unpack . printCSV . budgetReportAsCsv ropts
_ -> const $ error' $ unsupportedOutputFormatError fmt _ -> const $ error' $ unsupportedOutputFormatError fmt
writeOutput opts $ render budgetreport writeOutput opts $ render budgetreport
@ -330,21 +330,21 @@ balance opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
if multiperiod then do -- multi period balance report if multiperiod then do -- multi period balance report
let report = multiBalanceReport rspec j let report = multiBalanceReport rspec j
render = case fmt of render = case fmt of
"txt" -> multiBalanceReportAsText ropts "txt" -> TL.pack . multiBalanceReportAsText ropts
"csv" -> (++"\n") . printCSV . multiBalanceReportAsCsv ropts "csv" -> printCSV . multiBalanceReportAsCsv ropts
"html" -> (++"\n") . TL.unpack . L.renderText . multiBalanceReportAsHtml ropts "html" -> (<>"\n") . L.renderText . multiBalanceReportAsHtml ropts
"json" -> (++"\n") . TL.unpack . toJsonText "json" -> (<>"\n") . toJsonText
_ -> const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL: _ -> const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL:
writeOutput opts $ render report writeOutputLazyText opts $ render report
else do -- single period simple balance report else do -- single period simple balance report
let report = balanceReport rspec j -- simple Ledger-style balance report let report = balanceReport rspec j -- simple Ledger-style balance report
render = case fmt of render = case fmt of
"txt" -> balanceReportAsText "txt" -> \ropts -> TL.pack . balanceReportAsText ropts
"csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r "csv" -> \ropts -> printCSV . balanceReportAsCsv ropts
"json" -> const $ (++"\n") . TL.unpack . toJsonText "json" -> const $ (<>"\n") . toJsonText
_ -> const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL: _ -> error' $ unsupportedOutputFormatError fmt -- PARTIAL:
writeOutput opts $ render ropts report writeOutputLazyText opts $ render ropts report
-- XXX should all the per-report, per-format rendering code live in the command module, -- XXX should all the per-report, per-format rendering code live in the command module,
@ -356,11 +356,11 @@ balance opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
balanceReportAsCsv :: ReportOpts -> BalanceReport -> CSV balanceReportAsCsv :: ReportOpts -> BalanceReport -> CSV
balanceReportAsCsv opts (items, total) = balanceReportAsCsv opts (items, total) =
["account","balance"] : ["account","balance"] :
[[T.unpack a, showMixedAmountOneLineWithoutPrice False b] | (a, _, _, b) <- items] [[a, T.pack $ showMixedAmountOneLineWithoutPrice False b] | (a, _, _, b) <- items]
++ ++
if no_total_ opts if no_total_ opts
then [] then []
else [["total", showMixedAmountOneLineWithoutPrice False total]] else [["total", T.pack $ showMixedAmountOneLineWithoutPrice False total]]
-- | Render a single-column balance report as plain text. -- | Render a single-column balance report as plain text.
balanceReportAsText :: ReportOpts -> BalanceReport -> String balanceReportAsText :: ReportOpts -> BalanceReport -> String
@ -446,12 +446,12 @@ multiBalanceReportAsCsv :: ReportOpts -> MultiBalanceReport -> CSV
multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_} multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_}
(PeriodicReport colspans items (PeriodicReportRow _ coltotals tot avg)) = (PeriodicReport colspans items (PeriodicReportRow _ coltotals tot avg)) =
maybetranspose $ maybetranspose $
("Account" : map (T.unpack . showDateSpan) colspans ("Account" : map showDateSpan colspans
++ ["Total" | row_total_] ++ ["Total" | row_total_]
++ ["Average" | average_] ++ ["Average" | average_]
) : ) :
[T.unpack (displayFull a) : [displayFull a :
map (showMixedAmountOneLineWithoutPrice False) map (T.pack . showMixedAmountOneLineWithoutPrice False)
(amts (amts
++ [rowtot | row_total_] ++ [rowtot | row_total_]
++ [rowavg | average_]) ++ [rowavg | average_])
@ -460,7 +460,7 @@ multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_}
if no_total_ opts if no_total_ opts
then [] then []
else ["Total:" : else ["Total:" :
map (showMixedAmountOneLineWithoutPrice False) ( map (T.pack . showMixedAmountOneLineWithoutPrice False) (
coltotals coltotals
++ [tot | row_total_] ++ [tot | row_total_]
++ [avg | average_] ++ [avg | average_]
@ -496,7 +496,7 @@ multiBalanceReportHtmlRows ropts mbr =
) )
-- | Render one MultiBalanceReport heading row as a HTML table row. -- | Render one MultiBalanceReport heading row as a HTML table row.
multiBalanceReportHtmlHeadRow :: ReportOpts -> [String] -> Html () multiBalanceReportHtmlHeadRow :: ReportOpts -> [T.Text] -> Html ()
multiBalanceReportHtmlHeadRow _ [] = mempty -- shouldn't happen multiBalanceReportHtmlHeadRow _ [] = mempty -- shouldn't happen
multiBalanceReportHtmlHeadRow ropts (acct:rest) = multiBalanceReportHtmlHeadRow ropts (acct:rest) =
let let
@ -514,7 +514,7 @@ multiBalanceReportHtmlHeadRow ropts (acct:rest) =
++ [td_ [class_ "rowaverage", defstyle] (toHtml a) | a <- avg] ++ [td_ [class_ "rowaverage", defstyle] (toHtml a) | a <- avg]
-- | Render one MultiBalanceReport data row as a HTML table row. -- | Render one MultiBalanceReport data row as a HTML table row.
multiBalanceReportHtmlBodyRow :: ReportOpts -> [String] -> Html () multiBalanceReportHtmlBodyRow :: ReportOpts -> [T.Text] -> Html ()
multiBalanceReportHtmlBodyRow _ [] = mempty -- shouldn't happen multiBalanceReportHtmlBodyRow _ [] = mempty -- shouldn't happen
multiBalanceReportHtmlBodyRow ropts (label:rest) = multiBalanceReportHtmlBodyRow ropts (label:rest) =
let let
@ -532,7 +532,7 @@ multiBalanceReportHtmlBodyRow ropts (label:rest) =
++ [td_ [class_ "amount rowaverage", defstyle] (toHtml a) | a <- avg] ++ [td_ [class_ "amount rowaverage", defstyle] (toHtml a) | a <- avg]
-- | Render one MultiBalanceReport totals row as a HTML table row. -- | Render one MultiBalanceReport totals row as a HTML table row.
multiBalanceReportHtmlFootRow :: ReportOpts -> [String] -> Html () multiBalanceReportHtmlFootRow :: ReportOpts -> [T.Text] -> Html ()
multiBalanceReportHtmlFootRow _ropts [] = mempty multiBalanceReportHtmlFootRow _ropts [] = mempty
-- TODO pad totals row with zeros when subreport is empty -- TODO pad totals row with zeros when subreport is empty
-- multiBalanceReportHtmlFootRow ropts $ -- multiBalanceReportHtmlFootRow ropts $

35
hledger/Hledger/Cli/Commands/Print.hs
View File

@ -60,7 +60,7 @@ printEntries opts@CliOpts{reportspec_=rspec} j =
where where
fmt = outputFormatFromOpts opts fmt = outputFormatFromOpts opts
render | fmt=="txt" = entriesReportAsText opts render | fmt=="txt" = entriesReportAsText opts
| fmt=="csv" = TL.pack . printCSV . entriesReportAsCsv | fmt=="csv" = printCSV . entriesReportAsCsv
| fmt=="json" = toJsonText | fmt=="json" = toJsonText
| fmt=="sql" = entriesReportAsSql | fmt=="sql" = entriesReportAsSql
| otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL: | otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL:
@ -137,9 +137,7 @@ entriesReportAsSql txns = TB.toLazyText $ mconcat
where where
values vs = TB.fromText "(" <> mconcat (intersperse (TB.fromText ",") $ map toSql vs) <> TB.fromText ")\n" values vs = TB.fromText "(" <> mconcat (intersperse (TB.fromText ",") $ map toSql vs) <> TB.fromText ")\n"
toSql "" = TB.fromText "NULL" toSql "" = TB.fromText "NULL"
toSql s = TB.fromText "'" <> TB.fromString (concatMap quoteChar s) <> TB.fromText "'" toSql s = TB.fromText "'" <> TB.fromText (T.replace "'" "''" s) <> TB.fromText "'"
quoteChar '\'' = "''"
quoteChar c = [c]
csv = concatMap transactionToCSV txns csv = concatMap transactionToCSV txns
entriesReportAsCsv :: EntriesReport -> CSV entriesReportAsCsv :: EntriesReport -> CSV
@ -151,16 +149,16 @@ entriesReportAsCsv txns =
-- The txnidx field (transaction index) allows postings to be grouped back into transactions. -- The txnidx field (transaction index) allows postings to be grouped back into transactions.
transactionToCSV :: Transaction -> CSV transactionToCSV :: Transaction -> CSV
transactionToCSV t = transactionToCSV t =
map (\p -> show idx:date:date2:status:code:description:comment:p) map (\p -> T.pack (show idx):date:date2:status:code:description:comment:p)
(concatMap postingToCSV $ tpostings t) (concatMap postingToCSV $ tpostings t)
where where
idx = tindex t idx = tindex t
description = T.unpack $ tdescription t description = tdescription t
date = T.unpack $ showDate (tdate t) date = showDate (tdate t)
date2 = maybe "" (T.unpack . showDate) (tdate2 t) date2 = maybe "" showDate $ tdate2 t
status = show $ tstatus t status = T.pack . show $ tstatus t
code = T.unpack $ tcode t code = tcode t
comment = chomp $ strip $ T.unpack $ tcomment t comment = T.strip $ tcomment t
postingToCSV :: Posting -> CSV postingToCSV :: Posting -> CSV
postingToCSV p = postingToCSV p =
@ -168,17 +166,16 @@ postingToCSV p =
-- commodity goes into separate column, so we suppress it, along with digit group -- commodity goes into separate column, so we suppress it, along with digit group
-- separators and prices -- separators and prices
let a_ = a{acommodity="",astyle=(astyle a){asdigitgroups=Nothing},aprice=Nothing} in let a_ = a{acommodity="",astyle=(astyle a){asdigitgroups=Nothing},aprice=Nothing} in
let amount = showAmount a_ in let amount = T.pack $ showAmount a_ in
let commodity = T.unpack c in let credit = if q < 0 then T.pack . showAmount $ negate a_ else "" in
let credit = if q < 0 then showAmount $ negate a_ else "" in let debit = if q >= 0 then T.pack $ showAmount a_ else "" in
let debit = if q >= 0 then showAmount a_ else "" in [account, amount, c, credit, debit, status, comment])
[account, amount, commodity, credit, debit, status, comment])
amounts amounts
where where
Mixed amounts = pamount p Mixed amounts = pamount p
status = show $ pstatus p status = T.pack . show $ pstatus p
account = T.unpack $ showAccountName Nothing (ptype p) (paccount p) account = showAccountName Nothing (ptype p) (paccount p)
comment = T.unpack . textChomp . T.strip $ pcomment p comment = T.strip $ pcomment p
-- --match -- --match

16
hledger/Hledger/Cli/Commands/Register.hs
View File

@ -64,7 +64,7 @@ register opts@CliOpts{reportspec_=rspec} j =
where where
fmt = outputFormatFromOpts opts fmt = outputFormatFromOpts opts
render | fmt=="txt" = postingsReportAsText opts render | fmt=="txt" = postingsReportAsText opts
| fmt=="csv" = TL.pack . printCSV . postingsReportAsCsv | fmt=="csv" = printCSV . postingsReportAsCsv
| fmt=="json" = toJsonText | fmt=="json" = toJsonText
| otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL: | otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL:
@ -77,18 +77,18 @@ postingsReportAsCsv is =
postingsReportItemAsCsvRecord :: PostingsReportItem -> CsvRecord postingsReportItemAsCsvRecord :: PostingsReportItem -> CsvRecord
postingsReportItemAsCsvRecord (_, _, _, p, b) = [idx,date,code,desc,acct,amt,bal] postingsReportItemAsCsvRecord (_, _, _, p, b) = [idx,date,code,desc,acct,amt,bal]
where where
idx = show $ maybe 0 tindex $ ptransaction p idx = T.pack . show . maybe 0 tindex $ ptransaction p
date = T.unpack . showDate $ postingDate p -- XXX csv should show date2 with --date2 date = showDate $ postingDate p -- XXX csv should show date2 with --date2
code = maybe "" (T.unpack . tcode) $ ptransaction p code = maybe "" tcode $ ptransaction p
desc = T.unpack . maybe "" tdescription $ ptransaction p desc = maybe "" tdescription $ ptransaction p
acct = T.unpack . bracket $ paccount p acct = bracket $ paccount p
where where
bracket = case ptype p of bracket = case ptype p of
BalancedVirtualPosting -> wrap "[" "]" BalancedVirtualPosting -> wrap "[" "]"
VirtualPosting -> wrap "(" ")" VirtualPosting -> wrap "(" ")"
_ -> id _ -> id
amt = showMixedAmountOneLineWithoutPrice False $ pamount p amt = T.pack $ showMixedAmountOneLineWithoutPrice False $ pamount p
bal = showMixedAmountOneLineWithoutPrice False b bal = T.pack $ showMixedAmountOneLineWithoutPrice False b
-- | Render a register report as plain text suitable for console output. -- | Render a register report as plain text suitable for console output.
postingsReportAsText :: CliOpts -> PostingsReport -> TL.Text postingsReportAsText :: CliOpts -> PostingsReport -> TL.Text

22
hledger/Hledger/Cli/CompoundBalanceCommand.hs
View File

@ -154,7 +154,7 @@ compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportspec_=r
-- render appropriately -- render appropriately
render = case outputFormatFromOpts opts of render = case outputFormatFromOpts opts of
"txt" -> TL.pack . compoundBalanceReportAsText ropts' "txt" -> TL.pack . compoundBalanceReportAsText ropts'
"csv" -> TL.pack . printCSV . compoundBalanceReportAsCsv ropts' "csv" -> printCSV . compoundBalanceReportAsCsv ropts'
"html" -> L.renderText . compoundBalanceReportAsHtml ropts' "html" -> L.renderText . compoundBalanceReportAsHtml ropts'
"json" -> toJsonText "json" -> toJsonText
x -> error' $ unsupportedOutputFormatError x x -> error' $ unsupportedOutputFormatError x
@ -230,18 +230,18 @@ concatTables (Table hLeft hTop dat) (Table hLeft' _ dat') =
-- optional overall totals row is added. -- optional overall totals row is added.
compoundBalanceReportAsCsv :: ReportOpts -> CompoundPeriodicReport DisplayName MixedAmount -> CSV compoundBalanceReportAsCsv :: ReportOpts -> CompoundPeriodicReport DisplayName MixedAmount -> CSV
compoundBalanceReportAsCsv ropts (CompoundPeriodicReport title colspans subreports (PeriodicReportRow _ coltotals grandtotal grandavg)) = compoundBalanceReportAsCsv ropts (CompoundPeriodicReport title colspans subreports (PeriodicReportRow _ coltotals grandtotal grandavg)) =
addtotals $ addtotals $
padRow title : padRow (T.pack title)
map T.unpack ("Account" : : ( "Account"
map showDateSpanMonthAbbrev colspans : map showDateSpanMonthAbbrev colspans
++ (if row_total_ ropts then ["Total"] else []) ++ (if row_total_ ropts then ["Total"] else [])
++ (if average_ ropts then ["Average"] else []) ++ (if average_ ropts then ["Average"] else [])
) : )
concatMap (subreportAsCsv ropts) subreports : concatMap (subreportAsCsv ropts) subreports
where where
-- | Add a subreport title row and drop the heading row. -- | Add a subreport title row and drop the heading row.
subreportAsCsv ropts (subreporttitle, multibalreport, _) = subreportAsCsv ropts (subreporttitle, multibalreport, _) =
padRow subreporttitle : padRow (T.pack subreporttitle) :
tail (multiBalanceReportAsCsv ropts multibalreport) tail (multiBalanceReportAsCsv ropts multibalreport)
padRow s = take numcols $ s : repeat "" padRow s = take numcols $ s : repeat ""
where where
@ -257,7 +257,7 @@ compoundBalanceReportAsCsv ropts (CompoundPeriodicReport title colspans subrepor
| no_total_ ropts || length subreports == 1 = id | no_total_ ropts || length subreports == 1 = id
| otherwise = (++ | otherwise = (++
["Net:" : ["Net:" :
map (showMixedAmountOneLineWithoutPrice False) ( map (T.pack . showMixedAmountOneLineWithoutPrice False) (
coltotals coltotals
++ (if row_total_ ropts then [grandtotal] else []) ++ (if row_total_ ropts then [grandtotal] else [])
++ (if average_ ropts then [grandavg] else []) ++ (if average_ ropts then [grandavg] else [])