REF combine statement with history
This commit is contained in:
parent
55487982ec
commit
ba557639c2
|
|
@ -28,7 +28,6 @@ library
|
|||
Internal.Budget
|
||||
Internal.Database.Ops
|
||||
Internal.History
|
||||
Internal.Statement
|
||||
Internal.Types.Database
|
||||
Internal.Types.Dhall
|
||||
Internal.Types.Main
|
||||
|
|
|
|||
|
|
@ -7,14 +7,19 @@ module Internal.History
|
|||
where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Csv
|
||||
import Database.Persist.Monad
|
||||
import Internal.Database.Ops
|
||||
import Internal.Statement
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
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
|
||||
|
||||
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
||||
splitHistory = partitionEithers . fmap go
|
||||
|
|
@ -95,3 +100,227 @@ insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
|
|||
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
|
||||
k <- insert $ TransactionR c d e
|
||||
mapM_ (insertEntry k) ss
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements
|
||||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
|
||||
readImport Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
||||
let ores = compileOptions stmtTxOpts
|
||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
||||
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
||||
records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
|
||||
m <- askDBState kmCurrency
|
||||
fromEither $
|
||||
flip runReader m $
|
||||
runExceptT $
|
||||
matchRecords compiledMatches records
|
||||
|
||||
readImport_
|
||||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
=> Natural
|
||||
-> Word
|
||||
-> TxOptsRe
|
||||
-> FilePath
|
||||
-> m [TxRecord]
|
||||
readImport_ n delim tns p = do
|
||||
dir <- askDBState kmConfigDir
|
||||
res <- tryIO $ BL.readFile $ dir </> p
|
||||
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
|
||||
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
||||
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
|
||||
Right (_, v) -> return $ 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 {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} 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] -> InsertExceptT CurrencyM [BalTx]
|
||||
matchRecords ms rs = do
|
||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||
case (matched, unmatched, notfound) of
|
||||
-- TODO record number of times each match hits for debugging
|
||||
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
|
||||
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
|
||||
|
||||
matchPriorities :: [MatchRe] -> [MatchGroup]
|
||||
matchPriorities =
|
||||
fmap matchToGroup
|
||||
. L.groupBy (\a b -> spPriority a == spPriority b)
|
||||
. L.sortOn (Down . spPriority)
|
||||
|
||||
matchToGroup :: [MatchRe] -> MatchGroup
|
||||
matchToGroup ms =
|
||||
uncurry MatchGroup $
|
||||
first (L.sortOn spDate) $
|
||||
L.partition (isJust . spDate) 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
|
||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
|
||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||
where
|
||||
go _ [] = return (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 return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
||||
|
||||
-- TODO all this unpacking left/error crap is annoying
|
||||
zipperMatch'
|
||||
:: Zipped MatchRe
|
||||
-> TxRecord
|
||||
-> InsertExceptT CurrencyM (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 ->
|
||||
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
|
||||
go z' = return (z', MatchFail)
|
||||
|
||||
matchDec :: MatchRe -> Maybe MatchRe
|
||||
matchDec m = case spTimes m of
|
||||
Just 1 -> Nothing
|
||||
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||
Nothing -> Just m
|
||||
|
||||
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([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] -> InsertExceptT CurrencyM ([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) . spTimes) $ ud ++ un)
|
||||
|
||||
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
return
|
||||
( 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) $ spDate m
|
||||
|
||||
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchNonDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
return
|
||||
( 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 -> InsertExcept BalTx
|
||||
balanceTx t@Tx {txEntries = ss} = do
|
||||
bs <- balanceEntries ss
|
||||
return $ t {txEntries = bs}
|
||||
|
||||
balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
|
||||
balanceEntries ss =
|
||||
fmap concat
|
||||
<$> mapM (uncurry bal)
|
||||
$ groupByKey
|
||||
$ fmap (\s -> (eCurrency s, s)) ss
|
||||
where
|
||||
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
||||
haeValue s = Left s
|
||||
bal cur rss
|
||||
| length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
|
||||
| otherwise = case partitionEithers $ fmap haeValue rss of
|
||||
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
|
||||
([], val) -> return val
|
||||
_ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
|
||||
|
||||
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
|
||||
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
|
||||
|
|
|
|||
|
|
@ -1,241 +0,0 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Internal.Statement
|
||||
( readImport
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Error.Class
|
||||
import Control.Monad.Except
|
||||
import Data.Csv
|
||||
import Internal.Types.Main
|
||||
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 :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
|
||||
readImport Statement {..} = do
|
||||
let ores = compileOptions stmtTxOpts
|
||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
||||
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
||||
records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
|
||||
m <- askDBState kmCurrency
|
||||
fromEither $
|
||||
flip runReader m $
|
||||
runExceptT $
|
||||
matchRecords compiledMatches records
|
||||
|
||||
readImport_
|
||||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
=> Natural
|
||||
-> Word
|
||||
-> TxOptsRe
|
||||
-> FilePath
|
||||
-> m [TxRecord]
|
||||
readImport_ n delim tns p = do
|
||||
dir <- askDBState kmConfigDir
|
||||
res <- tryIO $ BL.readFile $ dir </> p
|
||||
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
|
||||
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
||||
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
|
||||
Right (_, v) -> return $ 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] -> InsertExceptT CurrencyM [BalTx]
|
||||
matchRecords ms rs = do
|
||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||
case (matched, unmatched, notfound) of
|
||||
-- TODO record number of times each match hits for debugging
|
||||
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
|
||||
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
|
||||
|
||||
matchPriorities :: [MatchRe] -> [MatchGroup]
|
||||
matchPriorities =
|
||||
fmap matchToGroup
|
||||
. L.groupBy (\a b -> spPriority a == spPriority b)
|
||||
. L.sortOn (Down . spPriority)
|
||||
|
||||
matchToGroup :: [MatchRe] -> MatchGroup
|
||||
matchToGroup ms =
|
||||
uncurry MatchGroup $
|
||||
first (L.sortOn spDate) $
|
||||
L.partition (isJust . spDate) 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
|
||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
|
||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||
where
|
||||
go _ [] = return (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 return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
||||
|
||||
-- TODO all this unpacking left/error crap is annoying
|
||||
zipperMatch'
|
||||
:: Zipped MatchRe
|
||||
-> TxRecord
|
||||
-> InsertExceptT CurrencyM (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 ->
|
||||
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
|
||||
go z' = return (z', MatchFail)
|
||||
|
||||
matchDec :: MatchRe -> Maybe MatchRe
|
||||
matchDec m = case spTimes m of
|
||||
Just 1 -> Nothing
|
||||
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||
Nothing -> Just m
|
||||
|
||||
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([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] -> InsertExceptT CurrencyM ([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) . spTimes) $ ud ++ un)
|
||||
|
||||
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
return
|
||||
( 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) $ spDate m
|
||||
|
||||
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchNonDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
return
|
||||
( 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 -> InsertExcept BalTx
|
||||
balanceTx t@Tx {txEntries = ss} = do
|
||||
bs <- balanceEntries ss
|
||||
return $ t {txEntries = bs}
|
||||
|
||||
balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
|
||||
balanceEntries ss =
|
||||
fmap concat
|
||||
<$> mapM (uncurry bal)
|
||||
$ groupByKey
|
||||
$ fmap (\s -> (eCurrency s, s)) ss
|
||||
where
|
||||
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
||||
haeValue s = Left s
|
||||
bal cur rss
|
||||
| length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
|
||||
| otherwise = case partitionEithers $ fmap haeValue rss of
|
||||
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
|
||||
([], val) -> return val
|
||||
_ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
|
||||
|
||||
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
|
||||
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
|
||||
Loading…
Reference in New Issue