{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Hledger.Read.CsvReader (
reader,
CSV, CsvRecord, CsvValue,
csvFileFor,
rulesFileFor,
parseRulesFile,
printCSV,
tests_CsvReader,
)
where
import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (fail)
import Control.Applicative (liftA2)
import Control.Exception (IOException, handle, throw)
import Control.Monad (liftM, unless, when)
import Control.Monad.Except (ExceptT, throwError)
import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State.Strict (StateT, get, modify', evalStateT)
import Control.Monad.Trans.Class (lift)
import Data.Char (toLower, isDigit, isSpace, isAlphaNum, isAscii, ord)
import Data.Bifunctor (first)
import "base-compat-batteries" Data.List.Compat
import qualified Data.List.Split as LS (splitOn)
import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.MemoUgly (memo)
import Data.Ord (comparing)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Data.Time.Calendar (Day)
import Data.Time.Format (parseTimeM, defaultTimeLocale)
import Safe (atMay, headMay, lastMay, readDef, readMay)
import System.Directory (doesFileExist)
import System.FilePath ((</>), takeDirectory, takeExtension, takeFileName)
import qualified Data.Csv as Cassava
import qualified Data.Csv.Parser.Megaparsec as CassavaMP
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Foldable (asum, toList)
import Text.Megaparsec hiding (match, parse)
import Text.Megaparsec.Char (char, newline, string)
import Text.Megaparsec.Custom (customErrorBundlePretty, parseErrorAt)
import Text.Printf (printf)
import Hledger.Data
import Hledger.Utils
import Hledger.Read.Common (Reader(..),InputOpts(..),amountp, statusp, genericSourcePos, journalFinalise)
type CSV = [CsvRecord]
type CsvRecord = [CsvValue]
type CsvValue = String
reader :: MonadIO m => Reader m
reader = Reader
{rFormat = "csv"
,rExtensions = ["csv","tsv","ssv"]
,rReadFn = parse
,rParser = error' "sorry, CSV files can't be included yet"
}
parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
parse iopts f t = do
let rulesfile = mrules_file_ iopts
r <- liftIO $ readJournalFromCsv rulesfile f t
case r of Left e -> throwError e
Right pj -> journalFinalise iopts{ignore_assertions_=True} f t pj'
where
pj' = journalReverse pj
parseRulesFile :: FilePath -> ExceptT String IO CsvRules
parseRulesFile f =
liftIO (readFilePortably f >>= expandIncludes (takeDirectory f))
>>= either throwError return . parseAndValidateCsvRules f
rulesFileFor :: FilePath -> FilePath
rulesFileFor = (++ ".rules")
csvFileFor :: FilePath -> FilePath
csvFileFor = reverse . drop 6 . reverse
defaultRulesText :: FilePath -> Text
defaultRulesText csvfile = T.pack $ unlines
["# hledger csv conversion rules for " ++ csvFileFor (takeFileName csvfile)
,"# cf http://hledger.org/manual#csv-files"
,""
,"account1 assets:bank:checking"
,""
,"fields date, description, amount1"
,""
,"#skip 1"
,"#newest-first"
,""
,"#date-format %-d/%-m/%Y"
,"#date-format %-m/%-d/%Y"
,"#date-format %Y-%h-%d"
,""
,"#currency $"
,""
,"if ITUNES"
," account2 expenses:entertainment"
,""
,"if (TO|FROM) SAVINGS"
," account2 assets:bank:savings\n"
]
addDirective :: (DirectiveName, String) -> CsvRulesParsed -> CsvRulesParsed
addDirective d r = r{rdirectives=d:rdirectives r}
addAssignment :: (HledgerFieldName, FieldTemplate) -> CsvRulesParsed -> CsvRulesParsed
addAssignment a r = r{rassignments=a:rassignments r}
setIndexesAndAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed
setIndexesAndAssignmentsFromList fs r = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs $ r
setCsvFieldIndexesFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed
setCsvFieldIndexesFromList fs r = r{rcsvfieldindexes=zip fs [1..]}
addAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed
addAssignmentsFromList fs r = foldl' maybeAddAssignment r journalfieldnames
where
maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs) rules
where
addAssignmentFromIndex i = addAssignment (f, "%"++show (i+1))
addConditionalBlock :: ConditionalBlock -> CsvRulesParsed -> CsvRulesParsed
addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r}
addConditionalBlocks :: [ConditionalBlock] -> CsvRulesParsed -> CsvRulesParsed
addConditionalBlocks bs r = r{rconditionalblocks=bs++rconditionalblocks r}
getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate
getDirective directivename = lookup directivename . rdirectives
instance ShowErrorComponent String where
showErrorComponent = id
expandIncludes :: FilePath -> Text -> IO Text
expandIncludes dir content = mapM (expandLine dir) (T.lines content) >>= return . T.unlines
where
expandLine dir line =
case line of
(T.stripPrefix "include " -> Just f) -> expandIncludes dir' =<< T.readFile f'
where
f' = dir </> dropWhile isSpace (T.unpack f)
dir' = takeDirectory f'
_ -> return line
parseAndValidateCsvRules :: FilePath -> T.Text -> Either String CsvRules
parseAndValidateCsvRules rulesfile s =
case parseCsvRules rulesfile s of
Left err -> Left $ customErrorBundlePretty err
Right rules -> first makeFancyParseError $ validateRules rules
where
makeFancyParseError :: String -> String
makeFancyParseError errorString =
parseErrorPretty (FancyError 0 (S.singleton $ ErrorFail errorString) :: ParseError Text String)
parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text CustomErr) CsvRules
parseCsvRules rulesfile s =
runParser (evalStateT rulesp defrules) rulesfile s
validateRules :: CsvRules -> Either String CsvRules
validateRules rules = do
unless (isAssigned "date") $ Left "Please specify (at top level) the date field. Eg: date %1\n"
Right rules
where
isAssigned f = isJust $ getEffectiveAssignment rules [] f
data CsvRules' a = CsvRules' {
rdirectives :: [(DirectiveName,String)],
rcsvfieldindexes :: [(CsvFieldName, CsvFieldIndex)],
rassignments :: [(HledgerFieldName, FieldTemplate)],
rconditionalblocks :: [ConditionalBlock],
rblocksassigning :: a
}
type CsvRulesParsed = CsvRules' ()
type CsvRules = CsvRules' (String -> [ConditionalBlock])
instance Eq CsvRules where
r1 == r2 = (rdirectives r1, rcsvfieldindexes r1, rassignments r1) ==
(rdirectives r2, rcsvfieldindexes r2, rassignments r2)
instance Show CsvRules where
show r = "CsvRules { rdirectives=" ++ show (rdirectives r) ++
", rcsvfieldindexes=" ++ show (rcsvfieldindexes r) ++
", rassignments=" ++ show (rassignments r) ++
", rconditionalblocks="++ show (rconditionalblocks r) ++
" }"
type CsvRulesParser a = StateT CsvRulesParsed SimpleTextParser a
type DirectiveName = String
type CsvFieldName = String
type CsvFieldIndex = Int
type CsvFieldReference = String
type HledgerFieldName = String
type FieldTemplate = String
type DateFormat = String
data MatcherPrefix = And | None
deriving (Show, Eq)
data Matcher =
RecordMatcher MatcherPrefix Regexp
| FieldMatcher MatcherPrefix CsvFieldReference Regexp
deriving (Show, Eq)
data ConditionalBlock = CB {
cbMatchers :: [Matcher]
,cbAssignments :: [(HledgerFieldName, FieldTemplate)]
} deriving (Show, Eq)
defrules :: CsvRulesParsed
defrules = CsvRules' {
rdirectives=[],
rcsvfieldindexes=[],
rassignments=[],
rconditionalblocks=[],
rblocksassigning = ()
}
mkrules :: CsvRulesParsed -> CsvRules
mkrules rules =
let conditionalblocks = reverse $ rconditionalblocks rules
maybeMemo = if length conditionalblocks >= 15 then memo else id
in
CsvRules' {
rdirectives=reverse $ rdirectives rules,
rcsvfieldindexes=rcsvfieldindexes rules,
rassignments=reverse $ rassignments rules,
rconditionalblocks=conditionalblocks,
rblocksassigning = maybeMemo (\f -> filter (any ((==f).fst) . cbAssignments) conditionalblocks)
}
matcherPrefix :: Matcher -> MatcherPrefix
matcherPrefix (RecordMatcher prefix _) = prefix
matcherPrefix (FieldMatcher prefix _ _) = prefix
groupedMatchers :: [Matcher] -> [[Matcher]]
groupedMatchers [] = []
groupedMatchers (x:xs) = (x:ys) : groupedMatchers zs
where (ys, zs) = span (\y -> matcherPrefix y == And) xs
rulesp :: CsvRulesParser CsvRules
rulesp = do
_ <- many $ choice
[blankorcommentlinep <?> "blank or comment line"
,(directivep >>= modify' . addDirective) <?> "directive"
,(fieldnamelistp >>= modify' . setIndexesAndAssignmentsFromList) <?> "field name list"
,(fieldassignmentp >>= modify' . addAssignment) <?> "field assignment"
,try (conditionalblockp >>= modify' . addConditionalBlock) <?> "conditional block"
,(conditionaltablep >>= modify' . addConditionalBlocks . reverse) <?> "conditional table"
]
eof
r <- get
return $ mkrules r
blankorcommentlinep :: CsvRulesParser ()
blankorcommentlinep = lift (dbgparse 8 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]
blanklinep :: CsvRulesParser ()
blanklinep = lift skipNonNewlineSpaces >> newline >> return () <?> "blank line"
commentlinep :: CsvRulesParser ()
commentlinep = lift skipNonNewlineSpaces >> commentcharp >> lift restofline >> return () <?> "comment line"
commentcharp :: CsvRulesParser Char
commentcharp = oneOf (";#*" :: [Char])
directivep :: CsvRulesParser (DirectiveName, String)
directivep = (do
lift $ dbgparse 8 "trying directive"
d <- fmap T.unpack $ choiceInState $ map (lift . string . T.pack) directives
v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)
<|> (optional (char ':') >> lift skipNonNewlineSpaces >> lift eolof >> return "")
return (d, v)
) <?> "directive"
directives :: [String]
directives =
["date-format"
,"separator"
,"skip"
,"newest-first"
, "balance-type"
]
directivevalp :: CsvRulesParser String
directivevalp = anySingle `manyTill` lift eolof
fieldnamelistp :: CsvRulesParser [CsvFieldName]
fieldnamelistp = (do
lift $ dbgparse 8 "trying fieldnamelist"
string "fields"
optional $ char ':'
lift skipNonNewlineSpaces1
let separator = lift skipNonNewlineSpaces >> char ',' >> lift skipNonNewlineSpaces
f <- fromMaybe "" <$> optional fieldnamep
fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep)
lift restofline
return $ map (map toLower) $ f:fs
) <?> "field name list"
fieldnamep :: CsvRulesParser String
fieldnamep = quotedfieldnamep <|> barefieldnamep
quotedfieldnamep :: CsvRulesParser String
quotedfieldnamep = do
char '"'
f <- some $ noneOf ("\"\n:;#~" :: [Char])
char '"'
return f
barefieldnamep :: CsvRulesParser String
barefieldnamep = some $ noneOf (" \t\n,;#~" :: [Char])
fieldassignmentp :: CsvRulesParser (HledgerFieldName, FieldTemplate)
fieldassignmentp = do
lift $ dbgparse 8 "trying fieldassignmentp"
f <- journalfieldnamep
v <- choiceInState [ assignmentseparatorp >> fieldvalp
, lift eolof >> return ""
]
return (f,v)
<?> "field assignment"
journalfieldnamep :: CsvRulesParser String
journalfieldnamep = do
lift (dbgparse 8 "trying journalfieldnamep")
T.unpack <$> choiceInState (map (lift . string . T.pack) journalfieldnames)
maxpostings = 99
journalfieldnames =
concat [[ "account" ++ i
,"amount" ++ i ++ "-in"
,"amount" ++ i ++ "-out"
,"amount" ++ i
,"balance" ++ i
,"comment" ++ i
,"currency" ++ i
] | x <- [maxpostings, (maxpostings-1)..1], let i = show x]
++
["amount-in"
,"amount-out"
,"amount"
,"balance"
,"code"
,"comment"
,"currency"
,"date2"
,"date"
,"description"
,"status"
,"skip"
,"end"
]
assignmentseparatorp :: CsvRulesParser ()
assignmentseparatorp = do
lift $ dbgparse 8 "trying assignmentseparatorp"
_ <- choiceInState [ lift skipNonNewlineSpaces >> char ':' >> lift skipNonNewlineSpaces
, lift skipNonNewlineSpaces1
]
return ()
fieldvalp :: CsvRulesParser String
fieldvalp = do
lift $ dbgparse 8 "trying fieldvalp"
anySingle `manyTill` lift eolof
conditionalblockp :: CsvRulesParser ConditionalBlock
conditionalblockp = do
lift $ dbgparse 8 "trying conditionalblockp"
start <- getOffset
string "if" >> ( (newline >> return Nothing)
<|> (lift skipNonNewlineSpaces1 >> optional newline))
ms <- some matcherp
as <- catMaybes <$>
many (lift skipNonNewlineSpaces1 >>
choice [ lift eolof >> return Nothing
, fmap Just fieldassignmentp
])
when (null as) $
customFailure $ parseErrorAt start $ "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n"
return $ CB{cbMatchers=ms, cbAssignments=as}
<?> "conditional block"
conditionaltablep :: CsvRulesParser [ConditionalBlock]
conditionaltablep = do
lift $ dbgparse 8 "trying conditionaltablep"
start <- getOffset
string "if"
sep <- lift $ satisfy (\c -> not (isAlphaNum c || isSpace c))
fields <- journalfieldnamep `sepBy1` (char sep)
newline
body <- flip manyTill (lift eolof) $ do
off <- getOffset
m <- matcherp' (char sep >> return ())
vs <- LS.splitOn [sep] <$> 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\n" (length fields) (length vs)) :: String)
else return (m,vs)
when (null body) $
customFailure $ parseErrorAt start $ "start of conditional table found, but no assignment rules afterward\n"
return $ flip map body $ \(m,vs) ->
CB{cbMatchers=[m], cbAssignments=zip fields vs}
<?> "conditional table"
matcherp' :: CsvRulesParser () -> CsvRulesParser Matcher
matcherp' end = try (fieldmatcherp end) <|> recordmatcherp end
matcherp :: CsvRulesParser Matcher
matcherp = matcherp' (lift eolof)
recordmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher
recordmatcherp end = do
lift $ dbgparse 8 "trying recordmatcherp"
p <- matcherprefixp
r <- regexp end
return $ RecordMatcher p r
<?> "record matcher"
fieldmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher
fieldmatcherp end = do
lift $ dbgparse 8 "trying fieldmatcher"
p <- matcherprefixp
f <- csvfieldreferencep <* lift skipNonNewlineSpaces
lift skipNonNewlineSpaces
r <- regexp end
return $ FieldMatcher p f r
<?> "field matcher"
matcherprefixp :: CsvRulesParser MatcherPrefix
matcherprefixp = do
lift $ dbgparse 8 "trying matcherprefixp"
(char '&' >> lift skipNonNewlineSpaces >> return And) <|> return None
csvfieldreferencep :: CsvRulesParser CsvFieldReference
csvfieldreferencep = do
lift $ dbgparse 8 "trying csvfieldreferencep"
char '%'
f <- fieldnamep
return $ '%' : quoteIfNeeded f
regexp :: CsvRulesParser () -> CsvRulesParser Regexp
regexp end = do
lift $ dbgparse 8 "trying regexp"
c <- lift nonspace
cs <- anySingle `manyTill` end
case toRegexCI . strip $ c:cs of
Left x -> Fail.fail $ "CSV parser: " ++ x
Right x -> return x
readJournalFromCsv :: Maybe FilePath -> FilePath -> Text -> IO (Either String Journal)
readJournalFromCsv Nothing "-" _ = return $ Left "please use --rules-file when reading CSV from stdin"
readJournalFromCsv mrulesfile csvfile csvdata =
handle (\(e::IOException) -> return $ Left $ show e) $ do
let throwerr = throw . userError
let rulesfile = fromMaybe (rulesFileFor csvfile) mrulesfile
rulesfileexists <- doesFileExist rulesfile
rulestext <-
if rulesfileexists
then do
dbg6IO "using conversion rules file" rulesfile
readFilePortably rulesfile >>= expandIncludes (takeDirectory rulesfile)
else
return $ defaultRulesText rulesfile
rules <- either throwerr return $ parseAndValidateCsvRules rulesfile rulestext
dbg6IO "rules" rules
let skiplines = case getDirective "skip" rules of
Nothing -> 0
Just "" -> 1
Just s -> readDef (throwerr $ "could not parse skip value: " ++ show s) s
let
parsecfilename = if csvfile == "-" then "(stdin)" else csvfile
separator =
case getDirective "separator" rules >>= parseSeparator of
Just c -> c
_ | ext == "ssv" -> ';'
_ | ext == "tsv" -> '\t'
_ -> ','
where
ext = map toLower $ drop 1 $ takeExtension csvfile
dbg6IO "using separator" separator
records <- (either throwerr id .
dbg7 "validateCsv" . validateCsv rules skiplines .
dbg7 "parseCsv")
`fmap` parseCsv separator parsecfilename csvdata
dbg6IO "first 3 csv records" $ take 3 records
let
txns = snd $ mapAccumL
(\pos r ->
let
SourcePos name line col = pos
line' = (mkPos . (+1) . unPos) line
pos' = SourcePos name line' col
in
(pos, transactionFromCsvRecord pos' rules r)
)
(initialPos parsecfilename) records
txns' =
(if newestfirst || mdataseemsnewestfirst == Just True then reverse else id) txns
where
newestfirst = dbg6 "newestfirst" $ isJust $ getDirective "newest-first" rules
mdataseemsnewestfirst = dbg6 "mdataseemsnewestfirst" $
case nub $ map tdate txns of
ds | length ds > 1 -> Just $ head ds > last ds
_ -> Nothing
txns'' = sortBy (comparing tdate) txns'
when (not rulesfileexists) $ do
dbg1IO "creating conversion rules file" rulesfile
writeFile rulesfile $ T.unpack rulestext
return $ Right nulljournal{jtxns=txns''}
parseSeparator :: String -> Maybe Char
parseSeparator = specials . map toLower
where specials "space" = Just ' '
specials "tab" = Just '\t'
specials (x:_) = Just x
specials [] = Nothing
parseCsv :: Char -> FilePath -> Text -> IO (Either String CSV)
parseCsv separator filePath csvdata =
case filePath of
"-" -> liftM (parseCassava separator "(stdin)") T.getContents
_ -> return $ parseCassava separator filePath csvdata
parseCassava :: Char -> FilePath -> Text -> Either String CSV
parseCassava separator path content =
either (Left . errorBundlePretty) (Right . parseResultToCsv) <$>
CassavaMP.decodeWith (decodeOptions separator) Cassava.NoHeader path $
BL.fromStrict $ T.encodeUtf8 content
decodeOptions :: Char -> Cassava.DecodeOptions
decodeOptions separator = Cassava.defaultDecodeOptions {
Cassava.decDelimiter = fromIntegral (ord separator)
}
parseResultToCsv :: (Foldable t, Functor t) => t (t B.ByteString) -> CSV
parseResultToCsv = toListList . unpackFields
where
toListList = toList . fmap toList
unpackFields = (fmap . fmap) (T.unpack . T.decodeUtf8)
printCSV :: CSV -> String
printCSV records = unlined (printRecord `map` records)
where printRecord = concat . intersperse "," . map printField
printField f = "\"" ++ concatMap escape f ++ "\""
escape '"' = "\"\""
escape x = [x]
unlined = concat . intersperse "\n"
validateCsv :: CsvRules -> Int -> Either String CSV -> Either String [CsvRecord]
validateCsv _ _ (Left err) = Left err
validateCsv rules numhdrlines (Right rs) = validate $ applyConditionalSkips $ drop numhdrlines $ filternulls rs
where
filternulls = filter (/=[""])
skipCount r =
case (getEffectiveAssignment rules r "end", getEffectiveAssignment rules r "skip") of
(Nothing, Nothing) -> Nothing
(Just _, _) -> Just maxBound
(Nothing, Just "") -> Just 1
(Nothing, Just x) -> Just (read x)
applyConditionalSkips [] = []
applyConditionalSkips (r:rest) =
case skipCount r of
Nothing -> r:(applyConditionalSkips rest)
Just cnt -> applyConditionalSkips (drop (cnt-1) rest)
validate [] = Right []
validate rs@(_first:_) = case lessthan2 of
Just r -> Left $ printf "CSV record %s has less than two fields" (show r)
Nothing -> Right rs
where
lessthan2 = headMay $ filter ((<2).length) rs
showRules rules record =
unlines $ catMaybes [ (("the "++fld++" rule is: ")++) <$> getEffectiveAssignment rules record fld | fld <- journalfieldnames]
csvRule :: CsvRules -> DirectiveName -> Maybe FieldTemplate
csvRule rules = (`getDirective` rules)
hledgerField :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe FieldTemplate
hledgerField = getEffectiveAssignment
hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe String
hledgerFieldValue rules record = fmap (renderTemplate rules record) . hledgerField rules record
transactionFromCsvRecord :: SourcePos -> CsvRules -> CsvRecord -> Transaction
transactionFromCsvRecord sourcepos rules record = t
where
rule = csvRule rules :: DirectiveName -> Maybe FieldTemplate
field = hledgerField rules record :: HledgerFieldName -> Maybe FieldTemplate
fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe String
parsedate = parseDateWithCustomOrDefaultFormats (rule "date-format")
mkdateerror datefield datevalue mdateformat = unlines
["error: could not parse \""++datevalue++"\" as a date using date format "
++maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" show mdateformat
,showRecord record
,"the "++datefield++" rule is: "++(fromMaybe "required, but missing" $ field datefield)
,"the date-format is: "++fromMaybe "unspecified" mdateformat
,"you may need to "
++"change your "++datefield++" rule, "
++maybe "add a" (const "change your") mdateformat++" date-format 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"
]
where
mskip = rule "skip"
mdateformat = rule "date-format"
date = fromMaybe "" $ fieldval "date"
date' = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate date
mdate2 = fieldval "date2"
mdate2' = maybe Nothing (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate) mdate2
status =
case fieldval "status" of
Nothing -> Unmarked
Just s -> either statuserror id $ runParser (statusp <* eof) "" $ T.pack s
where
statuserror err = error' $ unlines
["error: could not parse \""++s++"\" as a cleared status (should be *, ! or empty)"
,"the parse error is: "++customErrorBundlePretty err
]
code = maybe "" singleline $ fieldval "code"
description = maybe "" singleline $ fieldval "description"
comment = maybe "" singleline $ fieldval "comment"
precomment = maybe "" singleline $ fieldval "precomment"
p1IsVirtual = (accountNamePostingType . T.pack <$> fieldval "account1") == Just VirtualPosting
ps = [p | n <- [1..maxpostings]
,let comment = T.pack $ fromMaybe "" $ fieldval ("comment"++show n)
,let currency = fromMaybe "" (fieldval ("currency"++show n) <|> fieldval "currency")
,let mamount = getAmount rules record currency p1IsVirtual n
,let mbalance = getBalance rules record currency n
,Just (acct,isfinal) <- [getAccount rules record mamount mbalance n]
,let acct' | not isfinal && acct==unknownExpenseAccount &&
fromMaybe False (mamount >>= isNegativeMixedAmount) = unknownIncomeAccount
| otherwise = acct
,let p = nullposting{paccount = accountNameWithoutPostingType acct'
,pamount = fromMaybe missingmixedamt mamount
,ptransaction = Just t
,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance
,pcomment = comment
,ptype = accountNamePostingType acct
}
]
t = nulltransaction{
tsourcepos = genericSourcePos sourcepos
,tdate = date'
,tdate2 = mdate2'
,tstatus = status
,tcode = T.pack code
,tdescription = T.pack description
,tcomment = T.pack comment
,tprecedingcomment = T.pack precomment
,tpostings = ps
}
getAmount :: CsvRules -> CsvRecord -> String -> Bool -> Int -> Maybe MixedAmount
getAmount rules record currency p1IsVirtual n =
let
unnumberedfieldnames = ["amount","amount-in","amount-out"]
fieldnames = map (("amount"++show n)++) ["","-in","-out"]
++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else []
assignments = [(f,a') | f <- fieldnames
, Just v@(_:_) <- [strip . renderTemplate rules record <$> hledgerField rules record f]
, let a = parseAmount rules record currency v
, let a' = if f `elem` unnumberedfieldnames && n==2 then mixedAmountCost (-a) else a
]
assignments' | any isnumbered assignments = filter isnumbered assignments
| otherwise = assignments
where
isnumbered (f,_) = any (flip elem ['0'..'9']) f
assignments''
| length assignments' > 1 && not (null nonzeros) = nonzeros
| otherwise = assignments'
where nonzeros = filter (not . mixedAmountLooksZero . snd) assignments'
in case
assignments'' of
[] -> Nothing
[(f,a)] | "-out" `isSuffixOf` f -> Just (-a)
[(_,a)] -> Just a
fs -> error' $ unlines $ [
"multiple non-zero amounts or multiple zero amounts assigned,"
,"please ensure just one. (https://hledger.org/csv.html#amount)"
," " ++ showRecord record
," for posting: " ++ show n
]
++ [" assignment: " ++ f ++ " " ++
fromMaybe "" (hledgerField rules record f) ++
"\t=> value: " ++ showMixedAmount a
| (f,a) <- fs]
where
parseAmount :: CsvRules -> CsvRecord -> String -> String -> MixedAmount
parseAmount rules record currency amountstr =
either mkerror (Mixed . (:[])) $
runParser (evalStateT (amountp <* eof) nulljournal) "" $
T.pack $ (currency++) $ simplifySign amountstr
where
mkerror e = error' $ unlines
["error: could not parse \""++amountstr++"\" as an amount"
,showRecord record
,showRules rules record
,"the parse error is: "++customErrorBundlePretty e
,"you may need to "
++"change your amount*, balance*, or currency* rules, "
++"or add or change your skip rule"
]
getBalance :: CsvRules -> CsvRecord -> String -> Int -> Maybe (Amount, GenericSourcePos)
getBalance rules record currency n =
(fieldval ("balance"++show n)
<|> if n==1 then fieldval "balance" else Nothing)
>>= parsebalance currency n . strip
where
parsebalance currency n s
| null s = Nothing
| otherwise = Just
(either (mkerror n s) id $
runParser (evalStateT (amountp <* eof) nulljournal) "" $
T.pack $ (currency++) $ simplifySign s
,nullsourcepos)
where
mkerror n s e = error' $ unlines
["error: could not parse \""++s++"\" as balance"++show n++" amount"
,showRecord record
,showRules rules record
,"the parse error is: "++customErrorBundlePretty e
]
fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe String
mkBalanceAssertion :: CsvRules -> CsvRecord -> (Amount, GenericSourcePos) -> BalanceAssertion
mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos}
where
assrt =
case getDirective "balance-type" rules of
Nothing -> nullassertion
Just "=" -> nullassertion
Just "==" -> nullassertion{batotal=True}
Just "=*" -> nullassertion{bainclusive=True}
Just "==*" -> nullassertion{batotal=True, bainclusive=True}
Just x -> error' $ unlines
[ "balance-type \"" ++ x ++"\" is invalid. Use =, ==, =* or ==*."
, showRecord record
, showRules rules record
]
getAccount :: CsvRules -> CsvRecord -> Maybe MixedAmount -> Maybe (Amount, GenericSourcePos) -> Int -> Maybe (AccountName, Bool)
getAccount rules record mamount mbalance n =
let
fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe String
maccount = T.pack <$> fieldval ("account"++show n)
in case maccount of
Just "" -> Nothing
Just a -> Just (a, True)
Nothing ->
case (mamount, mbalance) of
(Just _, _) -> Just (unknownExpenseAccount, False)
(_, Just _) -> Just (unknownExpenseAccount, False)
(Nothing, Nothing) -> Nothing
unknownExpenseAccount = "expenses:unknown"
unknownIncomeAccount = "income:unknown"
type CsvAmountString = String
simplifySign :: CsvAmountString -> CsvAmountString
simplifySign ('(':s) | lastMay s == Just ')' = simplifySign $ negateStr $ init s
simplifySign ('-':'(':s) | lastMay s == Just ')' = simplifySign $ init s
simplifySign ('-':'-':s) = s
simplifySign s = s
negateStr :: String -> String
negateStr ('-':s) = s
negateStr s = '-':s
showRecord :: CsvRecord -> String
showRecord r = "record values: "++intercalate "," (map show r)
getEffectiveAssignment :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe FieldTemplate
getEffectiveAssignment rules record f = lastMay $ map snd $ assignments
where
assignments = dbg7 "assignments" $ filter ((==f).fst) $ toplevelassignments ++ conditionalassignments
where
toplevelassignments = rassignments rules
conditionalassignments = concatMap cbAssignments $ filter isBlockActive $ (rblocksassigning rules) f
where
isBlockActive :: ConditionalBlock -> Bool
isBlockActive CB{..} = any (all matcherMatches) $ groupedMatchers cbMatchers
where
matcherMatches :: Matcher -> Bool
matcherMatches (RecordMatcher _ pat) = regexMatch pat' wholecsvline
where
pat' = dbg7 "regex" pat
wholecsvline = dbg7 "wholecsvline" $ intercalate "," record
matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatch pat csvfieldvalue
where
csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref
renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> String
renderTemplate rules record t = maybe t concat $ parseMaybe
(many $ takeWhile1P Nothing (/='%')
<|> replaceCsvFieldReference rules record <$> referencep)
t
where
referencep = liftA2 (:) (char '%') (takeWhile1P (Just "reference") isDescriptorChar) :: Parsec CustomErr String String
isDescriptorChar c = isAscii c && (isAlphaNum c || c == '_' || c == '-')
replaceCsvFieldReference :: CsvRules -> CsvRecord -> CsvFieldReference -> String
replaceCsvFieldReference rules record s@('%':fieldname) = fromMaybe s $ csvFieldValue rules record fieldname
replaceCsvFieldReference _ _ s = s
csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe String
csvFieldValue rules record fieldname = do
fieldindex <- if | all isDigit fieldname -> readMay fieldname
| otherwise -> lookup (map toLower fieldname) $ rcsvfieldindexes rules
fieldvalue <- strip <$> atMay record (fieldindex-1)
return fieldvalue
parseDateWithCustomOrDefaultFormats :: Maybe DateFormat -> String -> Maybe Day
parseDateWithCustomOrDefaultFormats mformat s = asum $ map parsewith formats
where
parsewith = flip (parseTimeM True defaultTimeLocale) s
formats = maybe
["%Y/%-m/%-d"
,"%Y-%-m-%-d"
,"%Y.%-m.%-d"
]
(:[])
mformat
tests_CsvReader = tests "CsvReader" [
tests "parseCsvRules" [
test "empty file" $
parseCsvRules "unknown" "" @?= Right (mkrules defrules)
]
,tests "rulesp" [
test "trailing comments" $
parseWithState' defrules rulesp "skip\n# \n#\n" @?= Right (mkrules $ defrules{rdirectives = [("skip","")]})
,test "trailing blank lines" $
parseWithState' defrules rulesp "skip\n\n \n" @?= (Right (mkrules $ defrules{rdirectives = [("skip","")]}))
,test "no final newline" $
parseWithState' defrules rulesp "skip" @?= (Right (mkrules $ defrules{rdirectives=[("skip","")]}))
,test "assignment with empty value" $
parseWithState' defrules rulesp "account1 \nif foo\n account2 foo\n" @?=
(Right (mkrules $ defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher None (toRegex' "foo")],cbAssignments=[("account2","foo")]}]}))
]
,tests "conditionalblockp" [
test "space after conditional" $
parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?=
(Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]})
,tests "csvfieldreferencep" [
test "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1")
,test "name" $ parseWithState' defrules csvfieldreferencep "%date" @?= (Right "%date")
,test "quoted name" $ parseWithState' defrules csvfieldreferencep "%\"csv date\"" @?= (Right "%\"csv date\"")
]
,tests "matcherp" [
test "recordmatcherp" $
parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "A A")
,test "recordmatcherp.starts-with-&" $
parseWithState' defrules matcherp "& A A\n" @?= (Right $ RecordMatcher And $ toRegexCI' "A A")
,test "fieldmatcherp.starts-with-%" $
parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "description A A")
,test "fieldmatcherp" $
parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher None "%description" $ toRegexCI' "A A")
,test "fieldmatcherp.starts-with-&" $
parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A")
]
,tests "getEffectiveAssignment" [
let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]}
in test "toplevel" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate")
,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]}
in test "conditional" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate")
,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]}
in test "conditional-with-or-a" $ getEffectiveAssignment rules ["a"] "date" @?= (Just "%csvdate")
,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]}
in test "conditional-with-or-b" $ getEffectiveAssignment rules ["_", "b"] "date" @?= (Just "%csvdate")
,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b"] [("date","%csvdate")]]}
in test "conditional.with-and" $ getEffectiveAssignment rules ["a", "b"] "date" @?= (Just "%csvdate")
,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b", FieldMatcher None "%description" $ toRegex' "c"] [("date","%csvdate")]]}
in test "conditional.with-and-or" $ getEffectiveAssignment rules ["_", "c"] "date" @?= (Just "%csvdate")
]
]
]