{-# LANGUAGE CPP #-}
{-# 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 qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (fail)
import Control.Exception (IOException, handle, throw)
import Control.Monad (liftM, unless, when)
import Control.Monad.Except (ExceptT, throwError)
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, ord)
import Data.Bifunctor (first)
import "base-compat-batteries" Data.List.Compat
import Data.Maybe
import Data.Ord
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)
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (parseTimeM, defaultTimeLocale)
#else
import Data.Time.Format (parseTime)
import System.Locale (defaultTimeLocale)
#endif
import Safe
import System.Directory (doesFileExist)
import System.FilePath
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
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import Text.Megaparsec.Custom
import Text.Printf (printf)
import Hledger.Data
import Hledger.Utils
import Hledger.Read.Common (Reader(..),InputOpts(..),amountp, statusp, genericSourcePos, finaliseJournal)
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 -> finaliseJournal 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) -> CsvRules -> CsvRules
addDirective d r = r{rdirectives=d:rdirectives r}
addAssignment :: (HledgerFieldName, FieldTemplate) -> CsvRules -> CsvRules
addAssignment a r = r{rassignments=a:rassignments r}
setIndexesAndAssignmentsFromList :: [CsvFieldName] -> CsvRules -> CsvRules
setIndexesAndAssignmentsFromList fs r = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs $ r
setCsvFieldIndexesFromList :: [CsvFieldName] -> CsvRules -> CsvRules
setCsvFieldIndexesFromList fs r = r{rcsvfieldindexes=zip fs [1..]}
addAssignmentsFromList :: [CsvFieldName] -> CsvRules -> CsvRules
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 -> CsvRules -> CsvRules
addConditionalBlock b r = r{rconditionalblocks=b: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 = CsvRules {
rdirectives :: [(DirectiveName,String)],
rcsvfieldindexes :: [(CsvFieldName, CsvFieldIndex)],
rassignments :: [(HledgerFieldName, FieldTemplate)],
rconditionalblocks :: [ConditionalBlock]
} deriving (Show, Eq)
type CsvRulesParser a = StateT CsvRules SimpleTextParser a
type DirectiveName = String
type CsvFieldName = String
type CsvFieldIndex = Int
type CsvFieldReference = String
type HledgerFieldName = String
type FieldTemplate = String
type DateFormat = String
type RegexpPattern = String
data Matcher =
RecordMatcher RegexpPattern
| FieldMatcher CsvFieldReference RegexpPattern
deriving (Show, Eq)
data ConditionalBlock = CB {
cbMatchers :: [Matcher]
,cbAssignments :: [(HledgerFieldName, FieldTemplate)]
} deriving (Show, Eq)
defrules = CsvRules {
rdirectives=[],
rcsvfieldindexes=[],
rassignments=[],
rconditionalblocks=[]
}
rulesp :: CsvRulesParser CsvRules
rulesp = do
_ <- many $ choiceInState
[blankorcommentlinep <?> "blank or comment line"
,(directivep >>= modify' . addDirective) <?> "directive"
,(fieldnamelistp >>= modify' . setIndexesAndAssignmentsFromList) <?> "field name list"
,(fieldassignmentp >>= modify' . addAssignment) <?> "field assignment"
,(conditionalblockp >>= modify' . addConditionalBlock) <?> "conditional block"
]
eof
r <- get
return r{rdirectives=reverse $ rdirectives r
,rassignments=reverse $ rassignments r
,rconditionalblocks=reverse $ rconditionalblocks r
}
blankorcommentlinep :: CsvRulesParser ()
blankorcommentlinep = lift (dbgparse 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]
blanklinep :: CsvRulesParser ()
blanklinep = lift (skipMany spacenonewline) >> newline >> return () <?> "blank line"
commentlinep :: CsvRulesParser ()
commentlinep = lift (skipMany spacenonewline) >> commentcharp >> lift restofline >> return () <?> "comment line"
commentcharp :: CsvRulesParser Char
commentcharp = oneOf (";#*" :: [Char])
directivep :: CsvRulesParser (DirectiveName, String)
directivep = (do
lift $ dbgparse 3 "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 (skipMany spacenonewline) >> 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 3 "trying fieldnamelist"
string "fields"
optional $ char ':'
lift (skipSome spacenonewline)
let separator = lift (skipMany spacenonewline) >> char ',' >> lift (skipMany spacenonewline)
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 3 "trying fieldassignmentp"
f <- journalfieldnamep
v <- choiceInState [ assignmentseparatorp >> fieldvalp
, lift eolof >> return ""
]
return (f,v)
<?> "field assignment"
journalfieldnamep :: CsvRulesParser String
journalfieldnamep = do
lift (dbgparse 2 "trying journalfieldnamep")
T.unpack <$> choiceInState (map (lift . string . T.pack) journalfieldnames)
journalfieldnames =
concat [[ "account" ++ i
,"amount" ++ i ++ "-in"
,"amount" ++ i ++ "-out"
,"amount" ++ i
,"balance" ++ i
,"comment" ++ i
,"currency" ++ i
] | x <- [1..9], 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 3 "trying assignmentseparatorp"
_ <- choiceInState [ lift (skipMany spacenonewline) >> char ':' >> lift (skipMany spacenonewline)
, lift (skipSome spacenonewline)
]
return ()
fieldvalp :: CsvRulesParser String
fieldvalp = do
lift $ dbgparse 2 "trying fieldvalp"
anySingle `manyTill` lift eolof
conditionalblockp :: CsvRulesParser ConditionalBlock
conditionalblockp = do
lift $ dbgparse 3 "trying conditionalblockp"
string "if" >> lift (skipMany spacenonewline) >> optional newline
ms <- some matcherp
as <- many (try $ lift (skipSome spacenonewline) >> fieldassignmentp)
when (null as) $
Fail.fail "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"
matcherp :: CsvRulesParser Matcher
matcherp = try fieldmatcherp <|> recordmatcherp
recordmatcherp :: CsvRulesParser Matcher
recordmatcherp = do
lift $ dbgparse 2 "trying matcherp"
r <- regexp
return $ RecordMatcher r
<?> "record matcher"
fieldmatcherp :: CsvRulesParser Matcher
fieldmatcherp = do
lift $ dbgparse 2 "trying fieldmatcher"
f <- csvfieldreferencep <* lift (skipMany spacenonewline)
lift (skipMany spacenonewline)
r <- regexp
return $ FieldMatcher f r
<?> "field matcher"
csvfieldreferencep :: CsvRulesParser CsvFieldReference
csvfieldreferencep = do
lift $ dbgparse 3 "trying csvfieldreferencep"
char '%'
f <- fieldnamep
return $ '%' : quoteIfNeeded f
regexp :: CsvRulesParser RegexpPattern
regexp = do
lift $ dbgparse 3 "trying regexp"
c <- lift nonspace
cs <- anySingle `manyTill` lift eolof
return $ strip $ c:cs
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
dbg1IO "using conversion rules file" rulesfile
readFilePortably rulesfile >>= expandIncludes (takeDirectory rulesfile)
else
return $ defaultRulesText rulesfile
rules <- either throwerr return $ parseAndValidateCsvRules rulesfile rulestext
dbg2IO "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
let separator = fromMaybe ',' (getDirective "separator" rules >>= parseSeparator)
dbg2IO "separator" separator
records <- (either throwerr id .
dbg2 "validateCsv" . validateCsv rules skiplines .
dbg2 "parseCsv")
`fmap` parseCsv separator parsecfilename csvdata
dbg1IO "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 || mseemsnewestfirst == Just True then reverse else id) txns
where
newestfirst = dbg3 "newestfirst" $ isJust $ getDirective "newest-first" rules
mseemsnewestfirst = dbg3 "mseemsnewestfirst" $
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:_)
| isJust lessthan2 = let r = fromJust lessthan2 in
Left $ printf "CSV record %s has less than two fields" (show r)
| otherwise = 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)
csvRuleValue :: CsvRules -> CsvRecord -> DirectiveName -> Maybe String
csvRuleValue rules record = fmap (renderTemplate rules record) . csvRule 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
s `withDefault` def = if null s then def else s
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"
posting1 = mkPosting rules record "1"
("account1" `withAlias` "account")
("amount1" `withAlias` "amount")
("amount1-in" `withAlias` "amount-in")
("amount1-out" `withAlias` "amount-out")
("balance1" `withAlias` "balance")
"comment1"
t
where
withAlias fld alias =
case (field fld, field alias) of
(Just fld, Just alias) -> error' $ unlines
[ "error: both \"" ++ fld ++ "\" and \"" ++ alias ++ "\" have values."
, showRecord record
, showRules rules record
]
(Nothing, Just _) -> alias
(_, Nothing) -> fld
postings = catMaybes $ posting1 : otherpostings
where
otherpostings = [mkPostingN i | x<-[2..9], let i = show x]
where
mkPostingN n = mkPosting rules record n
("account"++n) ("amount"++n) ("amount"++n++"-in")
("amount"++n++"-out") ("balance"++n) ("comment"++n) t
postings' =
case postings of
[p1@(p1',_)] ->
if ptype p1' == VirtualPosting then [p1] else [p1, p2]
where
p2 = (nullposting{paccount=unknownExpenseAccount
,pamount=costOfMixedAmount (-pamount p1')
,ptransaction=Just t}, False)
[p1@(p1',_), p2@(p2',final2)] ->
if hasAmount p1' && not (hasAmount p2')
then [p1, (p2'{pamount=costOfMixedAmount(-(pamount p1'))}, final2)]
else [p1, p2]
ps -> ps
postings'' = map maybeImprove postings'
where
maybeImprove (p,final) = if final then p else improveUnknownAccountName p
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 = postings''
}
mkPosting ::
CsvRules -> CsvRecord -> String ->
HledgerFieldName -> HledgerFieldName -> HledgerFieldName ->
HledgerFieldName -> HledgerFieldName -> HledgerFieldName ->
Transaction ->
Maybe (Posting, Bool)
mkPosting rules record number accountFld amountFld amountInFld amountOutFld balanceFld commentFld t =
case maccountAndIsFinal of
Nothing -> Nothing
Just (acct, final) ->
Just (posting{paccount = accountNameWithoutPostingType acct
,pamount = fromMaybe missingmixedamt mamount
,ptransaction = Just t
,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance
,pcomment = comment
,ptype = accountNamePostingType acct}
,final)
where
maccountAndIsFinal :: Maybe (AccountName, Bool) =
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
where
maccount = T.pack <$> (fieldval accountFld
`withDefault` ruleval ("default-account" ++ number))
mdefaultcurrency = rule "default-currency"
currency = fromMaybe (fromMaybe "" mdefaultcurrency) $
fieldval ("currency"++number) `withDefault` fieldval "currency"
mamount = chooseAmount rules record currency amountFld amountInFld amountOutFld
mbalance :: Maybe (Amount, GenericSourcePos) =
fieldval balanceFld >>= parsebalance currency number
where
parsebalance currency n str
| all isSpace str = Nothing
| otherwise = Just
(either (balanceerror n str) id $
runParser (evalStateT (amountp <* eof) mempty) "" $
T.pack $ (currency++) $ simplifySign str
,nullsourcepos)
where
balanceerror n str err = error' $ unlines
["error: could not parse \""++str++"\" as balance"++n++" amount"
,showRecord record
,showRules rules record
,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency
,"the parse error is: "++customErrorBundlePretty err
]
comment = T.pack $ fromMaybe "" $ fieldval commentFld
rule = csvRule rules :: DirectiveName -> Maybe FieldTemplate
ruleval = csvRuleValue rules record :: DirectiveName -> Maybe String
fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe String
unknownExpenseAccount = "expenses:unknown"
unknownIncomeAccount = "income:unknown"
improveUnknownAccountName p@Posting{..}
| paccount == unknownExpenseAccount
&& fromMaybe False (isNegativeMixedAmount pamount) = p{paccount=unknownIncomeAccount}
| otherwise = p
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
]
chooseAmount :: CsvRules -> CsvRecord -> String -> String -> String -> String -> Maybe MixedAmount
chooseAmount rules record currency amountFld amountInFld amountOutFld =
let
mamount = getEffectiveAssignment rules record amountFld
mamountin = getEffectiveAssignment rules record amountInFld
mamountout = getEffectiveAssignment rules record amountOutFld
parse amt = notZero =<< (parseAmount currency <$> notEmpty =<< (strip . renderTemplate rules record) <$> amt)
in
case (parse mamount, parse mamountin, parse mamountout) of
(Nothing, Nothing, Nothing) -> Nothing
(Just a, Nothing, Nothing) -> Just a
(Nothing, Just i, Nothing) -> Just i
(Nothing, Nothing, Just o) -> Just $ negate o
(Nothing, Just i, Just o) -> error' $ "both "++amountInFld++" and "++amountOutFld++" have a value\n"
++ " "++amountInFld++": " ++ show i ++ "\n"
++ " "++amountOutFld++": " ++ show o ++ "\n"
++ " record: " ++ showRecord record
_ -> error' $ "found values for "++amountFld++" and for "++amountInFld++"/"++amountOutFld++"\n"
++ "please use either "++amountFld++" or "++amountInFld++"/"++amountOutFld++"\n"
++ " record: " ++ showRecord record
where
notZero amt = if isZeroMixedAmount amt then Nothing else Just amt
notEmpty str = if str=="" then Nothing else Just str
parseAmount currency amountstr =
either (amounterror amountstr) (Mixed . (:[]))
<$> runParser (evalStateT (amountp <* eof) mempty) ""
<$> T.pack
<$> (currency++)
<$> simplifySign
<$> amountstr
amounterror amountstr err = error' $ unlines
["error: could not parse \""++fromJust amountstr++"\" as an amount"
,showRecord record
,showRules rules record
,"the default-currency is: "++fromMaybe "unspecified" (getDirective "default-currency" rules)
,"the parse error is: "++customErrorBundlePretty err
,"you may need to "
++"change your amount or currency rules, "
++"or add or change your skip rule"
]
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 = "the CSV record is: "++intercalate "," (map show r)
getEffectiveAssignment :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe FieldTemplate
getEffectiveAssignment rules record f = lastMay $ map snd $ assignments
where
assignments = dbg2 "assignments" $ filter ((==f).fst) $ toplevelassignments ++ conditionalassignments
where
toplevelassignments = rassignments rules
conditionalassignments = concatMap cbAssignments $ filter isBlockActive $ blocksAssigning f
where
blocksAssigning f = filter (any ((==f).fst) . cbAssignments) $ rconditionalblocks rules
isBlockActive :: ConditionalBlock -> Bool
isBlockActive CB{..} = any matcherMatches cbMatchers
where
matcherMatches :: Matcher -> Bool
matcherMatches (RecordMatcher pat) = regexMatchesCI pat wholecsvline
where
wholecsvline = dbg3 "wholecsvline" $ intercalate "," record
matcherMatches (FieldMatcher csvfieldref pat) = regexMatchesCI pat csvfieldvalue
where
csvfieldvalue = dbg3 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref
renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> String
renderTemplate rules record t = regexReplaceBy "%[A-z0-9_-]+" (replaceCsvFieldReference rules record) t
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 = firstJust $ map parsewith formats
where
parsetime =
#if MIN_VERSION_time(1,5,0)
parseTimeM True
#else
parseTime
#endif
parsewith = flip (parsetime 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 defrules
]
,tests "rulesp" [
test "trailing comments" $
parseWithState' defrules rulesp "skip\n# \n#\n" @?= Right defrules{rdirectives = [("skip","")]}
,test "trailing blank lines" $
parseWithState' defrules rulesp "skip\n\n \n" @?= (Right defrules{rdirectives = [("skip","")]})
,test "no final newline" $
parseWithState' defrules rulesp "skip" @?= (Right defrules{rdirectives=[("skip","")]})
,test "assignment with empty value" $
parseWithState' defrules rulesp "account1 \nif foo\n account2 foo\n" @?=
(Right defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher "foo"],cbAssignments=[("account2","foo")]}]})
]
,tests "conditionalblockp" [
test "space after conditional" $
parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?=
(Right $ CB{cbMatchers=[RecordMatcher "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 "A A")
,test "fieldmatcherp.starts-with-%" $
parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher "description A A")
,test "fieldmatcherp" $
parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher "%description" "A A")
]
,tests "getEffectiveAssignment" [
let rules = defrules{rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]}
in test "toplevel" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate")
,let rules = defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher "%csvdate" "a"] [("date","%csvdate")]]}
in test "conditional" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate")
]
]
]