233 lines
7.6 KiB
Haskell
233 lines
7.6 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Internal.Statement
|
|
( readImport
|
|
)
|
|
where
|
|
|
|
import Data.Csv
|
|
import Internal.Types
|
|
import Internal.Utils
|
|
import RIO
|
|
import qualified RIO.ByteString.Lazy as BL
|
|
import RIO.FilePath
|
|
import qualified RIO.List as L
|
|
import qualified RIO.Map as M
|
|
import qualified RIO.Text as T
|
|
import RIO.Time
|
|
import qualified RIO.Vector as V
|
|
|
|
-- TODO this probably won't scale well (pipes?)
|
|
|
|
readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx])
|
|
readImport Statement {..} = do
|
|
let ores = plural $ compileOptions impTxOpts
|
|
let cres = concatEithersL $ compileMatch <$> impMatches
|
|
case concatEithers2 ores cres (,) of
|
|
Right (compiledOptions, compiledMatches) -> do
|
|
ires <- mapM (readImport_ impSkipLines impDelim compiledOptions) impPaths
|
|
case concatEitherL ires of
|
|
Right records -> return $ matchRecords compiledMatches $ L.sort $ concat records
|
|
Left es -> return $ Left es
|
|
Left es -> return $ Left es
|
|
|
|
readImport_
|
|
:: MonadFinance m
|
|
=> Natural
|
|
-> Word
|
|
-> TxOptsRe
|
|
-> FilePath
|
|
-> m (EitherErr [TxRecord])
|
|
readImport_ n delim tns p = do
|
|
dir <- askDBState kmConfigDir
|
|
bs <- liftIO $ BL.readFile $ dir </> p
|
|
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
|
Left m -> return $ Left $ ParseError $ T.pack m
|
|
Right (_, v) -> return $ Right $ catMaybes $ V.toList v
|
|
where
|
|
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
|
|
skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
|
|
|
|
-- TODO handle this better, this maybe thing is a hack to skip lines with
|
|
-- blank dates but will likely want to make this more flexible
|
|
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
|
|
parseTxRecord p TxOpts {..} r = do
|
|
d <- r .: T.encodeUtf8 toDate
|
|
if d == ""
|
|
then return Nothing
|
|
else do
|
|
a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
|
e <- r .: T.encodeUtf8 toDesc
|
|
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
|
|
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
|
return $ Just $ TxRecord d' a e os p
|
|
|
|
matchRecords :: [MatchRe] -> [TxRecord] -> EitherErrs [BalTx]
|
|
matchRecords ms rs = do
|
|
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
|
case (matched, unmatched, notfound) of
|
|
(ms_, [], []) -> do
|
|
-- TODO record number of times each match hits for debugging
|
|
matched_ <- first (: []) $ mapM balanceTx ms_
|
|
Right matched_
|
|
(_, us, ns) -> Left [StatementError us ns]
|
|
|
|
matchPriorities :: [MatchRe] -> [MatchGroup]
|
|
matchPriorities =
|
|
fmap matchToGroup
|
|
. L.groupBy (\a b -> mPriority a == mPriority b)
|
|
. L.sortOn (Down . mPriority)
|
|
|
|
matchToGroup :: [MatchRe] -> MatchGroup
|
|
matchToGroup ms =
|
|
uncurry MatchGroup $
|
|
first (L.sortOn mDate) $
|
|
L.partition (isJust . mDate) ms
|
|
|
|
-- TDOO could use a better struct to flatten the maybe date subtype
|
|
data MatchGroup = MatchGroup
|
|
{ mgDate :: ![MatchRe]
|
|
, mgNoDate :: ![MatchRe]
|
|
}
|
|
deriving (Show)
|
|
|
|
data Zipped a = Zipped ![a] ![a]
|
|
|
|
data Unzipped a = Unzipped ![a] ![a] ![a]
|
|
|
|
initZipper :: [a] -> Zipped a
|
|
initZipper = Zipped []
|
|
|
|
resetZipper :: Zipped a -> Zipped a
|
|
resetZipper = initZipper . recoverZipper
|
|
|
|
recoverZipper :: Zipped a -> [a]
|
|
recoverZipper (Zipped as bs) = reverse as ++ bs
|
|
|
|
zipperSlice
|
|
:: (a -> b -> Ordering)
|
|
-> b
|
|
-> Zipped a
|
|
-> Either (Zipped a) (Unzipped a)
|
|
zipperSlice f x = go
|
|
where
|
|
go z@(Zipped _ []) = Left z
|
|
go z@(Zipped bs (a : as)) =
|
|
case f a x of
|
|
GT -> go $ Zipped (a : bs) as
|
|
EQ -> Right $ goEq (Unzipped bs [a] as)
|
|
LT -> Left z
|
|
goEq z@(Unzipped _ _ []) = z
|
|
goEq z@(Unzipped bs cs (a : as)) =
|
|
case f a x of
|
|
GT -> goEq $ Unzipped (a : bs) cs as
|
|
EQ -> goEq $ Unzipped bs (a : cs) as
|
|
LT -> z
|
|
|
|
zipperMatch :: Unzipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx)
|
|
zipperMatch (Unzipped bs cs as) x = go [] cs
|
|
where
|
|
go _ [] = Right (Zipped bs $ cs ++ as, MatchFail)
|
|
go prev (m : ms) = do
|
|
res <- matches m x
|
|
case res of
|
|
MatchFail -> go (m : prev) ms
|
|
skipOrPass ->
|
|
let ps = reverse prev
|
|
ms' = maybe ms (: ms) (matchDec m)
|
|
in Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
|
|
|
zipperMatch' :: Zipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx)
|
|
zipperMatch' z x = go z
|
|
where
|
|
go (Zipped bs (a : as)) = do
|
|
res <- matches a x
|
|
case res of
|
|
MatchFail -> go (Zipped (a : bs) as)
|
|
skipOrPass -> Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
|
|
go z' = Right (z', MatchFail)
|
|
|
|
matchDec :: MatchRe -> Maybe MatchRe
|
|
matchDec m = case mTimes m of
|
|
Just 1 -> Nothing
|
|
Just n -> Just $ m {mTimes = Just $ n - 1}
|
|
Nothing -> Just m
|
|
|
|
matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
|
matchAll = go ([], [])
|
|
where
|
|
go (matched, unused) gs rs = case (gs, rs) of
|
|
(_, []) -> return (matched, [], unused)
|
|
([], _) -> return (matched, rs, unused)
|
|
(g : gs', _) -> do
|
|
(ts, unmatched, us) <- matchGroup g rs
|
|
go (ts ++ matched, us ++ unused) gs' unmatched
|
|
|
|
matchGroup :: MatchGroup -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
|
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
|
(md, rest, ud) <- matchDates ds rs
|
|
(mn, unmatched, un) <- matchNonDates ns rest
|
|
return (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
|
|
|
|
matchDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
|
matchDates ms = go ([], [], initZipper ms)
|
|
where
|
|
go (matched, unmatched, z) [] =
|
|
Right
|
|
( catMaybes matched
|
|
, reverse unmatched
|
|
, recoverZipper z
|
|
)
|
|
go (matched, unmatched, z) (r : rs) =
|
|
case zipperSlice findDate r z of
|
|
Left zipped -> go (matched, r : unmatched, zipped) rs
|
|
Right unzipped -> do
|
|
(z', res) <- zipperMatch unzipped r
|
|
let (m, u) = case res of
|
|
MatchPass p -> (Just p : matched, unmatched)
|
|
MatchSkip -> (Nothing : matched, unmatched)
|
|
MatchFail -> (matched, r : unmatched)
|
|
go (m, u, z') rs
|
|
findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
|
|
|
|
matchNonDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
|
matchNonDates ms = go ([], [], initZipper ms)
|
|
where
|
|
go (matched, unmatched, z) [] =
|
|
Right
|
|
( catMaybes matched
|
|
, reverse unmatched
|
|
, recoverZipper z
|
|
)
|
|
go (matched, unmatched, z) (r : rs) = do
|
|
(z', res) <- zipperMatch' z r
|
|
let (m, u) = case res of
|
|
MatchPass p -> (Just p : matched, unmatched)
|
|
MatchSkip -> (Nothing : matched, unmatched)
|
|
MatchFail -> (matched, r : unmatched)
|
|
in go (m, u, resetZipper z') rs
|
|
|
|
balanceTx :: RawTx -> EitherErr BalTx
|
|
balanceTx t@Tx {txSplits = ss} = do
|
|
bs <- balanceSplits ss
|
|
return $ t {txSplits = bs}
|
|
|
|
balanceSplits :: [RawSplit] -> EitherErr [BalSplit]
|
|
balanceSplits ss =
|
|
fmap concat
|
|
<$> mapM (uncurry bal)
|
|
$ groupByKey
|
|
$ fmap (\s -> (sCurrency s, s)) ss
|
|
where
|
|
hasValue s@Entry {sValue = Just v} = Right s {sValue = v}
|
|
hasValue s = Left s
|
|
bal cur rss
|
|
| length rss < 2 = Left $ BalanceError TooFewSplits cur rss
|
|
| otherwise = case partitionEithers $ fmap hasValue rss of
|
|
([noVal], val) -> Right $ noVal {sValue = foldr (\s x -> x - sValue s) 0 val} : val
|
|
([], val) -> Right val
|
|
_ -> Left $ BalanceError NotOneBlank cur rss
|
|
|
|
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
|
|
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
|