531 lines
17 KiB
Haskell
531 lines
17 KiB
Haskell
module Internal.History
|
|
( readHistStmt
|
|
, readHistTransfer
|
|
, splitHistory
|
|
, readHistoryCRUD
|
|
)
|
|
where
|
|
|
|
import Control.Monad.Except
|
|
import Data.Csv
|
|
import Data.Decimal
|
|
import Data.Foldable
|
|
import Data.Hashable
|
|
import GHC.Real
|
|
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
|
|
import Text.Regex.TDFA hiding (matchAll)
|
|
import Text.Regex.TDFA.Text
|
|
|
|
readHistoryCRUD
|
|
:: (MonadUnliftIO m, MonadFinance m)
|
|
=> FilePath
|
|
-> PreHistoryCRUD
|
|
-> m FinalHistoryCRUD
|
|
readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
|
|
-- TODO multithread this for some extra fun :)
|
|
|
|
ss' <- mapM (readHistStmt root) ss
|
|
fromEitherM $ runExceptT $ do
|
|
let sRes = mapErrors (ExceptT . return) ss'
|
|
let tRes = mapErrors readHistTransfer ts
|
|
combineError sRes tRes $ \ss'' ts' -> o {coCreate = concat ss'' ++ concat ts'}
|
|
|
|
-- NOTE keep statement and transfer readers separate because the former needs
|
|
-- the IO monad, and thus will throw IO errors rather than using the ExceptT
|
|
-- thingy
|
|
splitHistory :: [History] -> ([PairedTransfer], [Statement])
|
|
splitHistory = partitionEithers . fmap go
|
|
where
|
|
go (HistTransfer x) = Left x
|
|
go (HistStatement x) = Right x
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Transfers
|
|
|
|
readHistTransfer
|
|
:: (MonadAppError m, MonadFinance m)
|
|
=> PairedTransfer
|
|
-> m [Tx CommitR]
|
|
readHistTransfer ht = do
|
|
bounds <- asks (unHSpan . tsHistoryScope)
|
|
expandTransfer c bounds ht
|
|
where
|
|
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Statements
|
|
|
|
readHistStmt
|
|
:: (MonadUnliftIO m, MonadFinance m)
|
|
=> FilePath
|
|
-> Statement
|
|
-> m (Either AppException [Tx CommitR])
|
|
readHistStmt root i = do
|
|
bounds <- asks (unHSpan . tsHistoryScope)
|
|
bs <- readImport root i
|
|
return $ filter (inDaySpan bounds . txDate) . fmap (\t -> t {txCommit = c}) <$> bs
|
|
where
|
|
c = CommitR (CommitHash $ hash i) CTHistoryStatement
|
|
|
|
-- TODO this probably won't scale well (pipes?)
|
|
readImport
|
|
:: (MonadUnliftIO m, MonadFinance m)
|
|
=> FilePath
|
|
-> Statement
|
|
-> m (Either AppException [Tx ()])
|
|
readImport root 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 paths
|
|
runExceptT (matchRecords compiledMatches records)
|
|
where
|
|
paths = (root </>) <$> stmtPaths
|
|
|
|
readImport_
|
|
:: MonadUnliftIO m
|
|
=> Natural
|
|
-> Word
|
|
-> TxOptsRe
|
|
-> FilePath
|
|
-> m [TxRecord]
|
|
readImport_ n delim tns p = do
|
|
res <- tryIO $ BL.readFile p
|
|
bs <- fromEither $ first (AppException . (: []) . StatementIOError . tshow) res
|
|
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
|
Left m -> throwIO $ AppException [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 <- parseDecimal 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 :: MonadFinance m => [MatchRe] -> [TxRecord] -> AppExceptT m [Tx ()]
|
|
matchRecords ms rs = do
|
|
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
|
case (matched, unmatched, notfound) of
|
|
(ms_, [], []) -> return ms_
|
|
(_, us, ns) -> throwError $ AppException [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
|
|
|
|
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
|
|
:: MonadFinance m
|
|
=> Unzipped MatchRe
|
|
-> TxRecord
|
|
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
|
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)
|
|
|
|
zipperMatch'
|
|
:: MonadFinance m
|
|
=> Zipped MatchRe
|
|
-> TxRecord
|
|
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
|
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
|
|
:: MonadFinance m
|
|
=> [MatchGroup]
|
|
-> [TxRecord]
|
|
-> AppExceptT m ([Tx ()], [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
|
|
:: MonadFinance m
|
|
=> MatchGroup
|
|
-> [TxRecord]
|
|
-> AppExceptT m ([Tx ()], [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
|
|
:: MonadFinance m
|
|
=> [MatchRe]
|
|
-> [TxRecord]
|
|
-> AppExceptT m ([Tx ()], [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
|
|
:: MonadFinance m
|
|
=> [MatchRe]
|
|
-> [TxRecord]
|
|
-> AppExceptT m ([Tx ()], [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
|
|
|
|
matches :: MonadFinance m => MatchRe -> TxRecord -> AppExceptT m (MatchRes (Tx ()))
|
|
matches
|
|
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
|
|
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
|
res <- liftInner $
|
|
combineError3 val other desc $
|
|
\x y z -> x && y && z && date
|
|
if res
|
|
then maybe (return MatchSkip) convert spTx
|
|
else return MatchFail
|
|
where
|
|
val = valMatches spVal $ toRational trAmount
|
|
date = maybe True (`dateMatches` trDate) spDate
|
|
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
|
|
desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc
|
|
convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
|
|
|
|
toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> AppExceptT m (Tx ())
|
|
toTx
|
|
priority
|
|
TxGetter
|
|
{ tgFrom
|
|
, tgTo
|
|
, tgCurrency
|
|
, tgOtherEntries
|
|
, tgScale
|
|
}
|
|
r@TxRecord {trAmount, trDate, trDesc} = do
|
|
combineError curRes subRes $ \(cur, f, t) ss ->
|
|
Tx
|
|
{ txDate = trDate
|
|
, txDesc = trDesc
|
|
, txCommit = ()
|
|
, txPrimary =
|
|
Left $
|
|
EntrySet
|
|
{ esTotalValue = roundToP (cpPrec cur) trAmount *. tgScale
|
|
, esCurrency = cpID cur
|
|
, esFrom = f
|
|
, esTo = t
|
|
}
|
|
, txOther = Left <$> ss
|
|
, txPriority = priority
|
|
}
|
|
where
|
|
curRes = do
|
|
m <- asks tsCurrencyMap
|
|
cur <- liftInner $ resolveCurrency m r tgCurrency
|
|
let prec = cpPrec cur
|
|
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
|
|
let toRes = liftInner $ resolveHalfEntry resolveToValue prec r () tgTo
|
|
combineError fromRes toRes (cur,,)
|
|
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
|
|
|
|
resolveSubGetter
|
|
:: MonadFinance m
|
|
=> TxRecord
|
|
-> TxSubGetter
|
|
-> AppExceptT m SecondayEntrySet
|
|
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
|
m <- asks tsCurrencyMap
|
|
cur <- liftInner $ resolveCurrency m r tsgCurrency
|
|
let prec = cpPrec cur
|
|
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
|
|
let valRes = liftInner $ resolveValue prec r tsgValue
|
|
liftInner $ combineErrorM toRes valRes $ \t v -> do
|
|
f <- resolveHalfEntry resolveFromValue prec r v tsgFrom
|
|
return $
|
|
EntrySet
|
|
{ esTotalValue = ()
|
|
, esCurrency = cpID cur
|
|
, esFrom = f
|
|
, esTo = t
|
|
}
|
|
|
|
resolveHalfEntry
|
|
:: (Precision -> TxRecord -> n -> AppExcept v')
|
|
-> Precision
|
|
-> TxRecord
|
|
-> v
|
|
-> TxHalfGetter (EntryGetter n)
|
|
-> AppExcept (HalfEntrySet v v')
|
|
resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
|
|
combineError acntRes esRes $ \a es ->
|
|
HalfEntrySet
|
|
{ hesPrimary =
|
|
Entry
|
|
{ eAcnt = a
|
|
, eValue = v
|
|
, eComment = thgComment
|
|
, eTags = thgTags
|
|
}
|
|
, hesOther = es
|
|
}
|
|
where
|
|
acntRes = resolveAcnt r thgAcnt
|
|
esRes = mapErrors (resolveEntry f prec r) thgEntries
|
|
|
|
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> AppExcept Bool
|
|
otherMatches dict m = case m of
|
|
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
|
|
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
|
|
where
|
|
lookup_ t n = lookupErr (MatchField t) n dict
|
|
|
|
resolveEntry
|
|
:: (Precision -> TxRecord -> n -> AppExcept v)
|
|
-> Precision
|
|
-> TxRecord
|
|
-> EntryGetter n
|
|
-> AppExcept (Entry AcntID v TagID)
|
|
resolveEntry f prec r s@Entry {eAcnt, eValue} =
|
|
combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
|
|
where
|
|
acntRes = resolveAcnt r eAcnt
|
|
valRes = f prec r eValue
|
|
|
|
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
|
|
resolveFromValue = resolveValue
|
|
|
|
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> AppExcept EntryLink
|
|
resolveToValue _ _ (Linked l) = return $ LinkIndex l
|
|
resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
|
|
|
|
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
|
|
resolveValue prec TxRecord {trOther, trAmount} s = case s of
|
|
(LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
|
|
(ConstN c) -> return $ EntryFixed $ go c
|
|
AmountN m -> return $ EntryFixed $ trAmount *. m
|
|
BalanceN x -> return $ EntryBalance $ go x
|
|
PercentN x -> return $ EntryPercent x
|
|
where
|
|
go = realFracToDecimalP prec
|
|
|
|
resolveAcnt :: TxRecord -> EntryAcnt -> AppExcept AcntID
|
|
resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
|
|
|
|
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> AppExcept CurrencyPrec
|
|
resolveCurrency m r c = do
|
|
i <- resolveEntryField CurField r (unCurID <$> c)
|
|
case M.lookup (CurID i) m of
|
|
Just k -> return k
|
|
Nothing -> throwError $ AppException [LookupError (DBKey CurField) i]
|
|
|
|
resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> AppExcept T.Text
|
|
resolveEntryField t TxRecord {trOther = o} s = case s of
|
|
ConstT p -> return p
|
|
LookupT f -> lookup_ f o
|
|
MapT (Field f m) -> do
|
|
k <- lookup_ f o
|
|
lookup_ k m
|
|
Map2T (Field (f1, f2) m) -> do
|
|
(k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
|
|
lookup_ (k1, k2) m
|
|
where
|
|
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> AppExcept v
|
|
lookup_ = lookupErr (EntryIDField t)
|
|
|
|
readDouble :: T.Text -> AppExcept Double
|
|
readDouble s = case readMaybe $ T.unpack s of
|
|
Just x -> return x
|
|
Nothing -> throwError $ AppException [ConversionError s True]
|
|
|
|
readRational :: T.Text -> AppExcept Rational
|
|
readRational s = case T.split (== '.') s of
|
|
[x] -> maybe err (return . fromInteger) $ readT x
|
|
[x, y] -> case (readT x, readT y) of
|
|
(Just x', Just y') ->
|
|
let p = 10 ^ T.length y
|
|
k = if x' >= 0 then 1 else -1
|
|
in return $ fromInteger x' + k * y' % p
|
|
_ -> err
|
|
_ -> err
|
|
where
|
|
readT = readMaybe . T.unpack
|
|
err = throwError $ AppException [ConversionError s False]
|
|
|
|
compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
|
|
compileOptions o@TxOpts {toAmountFmt = pat} = do
|
|
re <- compileRegex True pat
|
|
return $ o {toAmountFmt = re}
|
|
|
|
compileMatch :: StatementParser T.Text -> AppExcept MatchRe
|
|
compileMatch m@StatementParser {spDesc, spOther} = do
|
|
combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
|
|
where
|
|
go = compileRegex False
|
|
dres = mapM go spDesc
|
|
ores = combineErrors $ fmap (mapM go) spOther
|
|
|
|
compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
|
|
compileRegex groups pat = case res of
|
|
Right re -> return (pat, re)
|
|
Left _ -> throwError $ AppException [RegexError pat]
|
|
where
|
|
res =
|
|
compile
|
|
(blankCompOpt {newSyntax = True})
|
|
(blankExecOpt {captureGroups = groups})
|
|
pat
|
|
|
|
matchMaybe :: T.Text -> Regex -> AppExcept Bool
|
|
matchMaybe q re = case execute re q of
|
|
Right res -> return $ isJust res
|
|
Left _ -> throwError $ AppException [RegexError "this should not happen"]
|
|
|
|
matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
|
|
matchGroupsMaybe q re = case regexec re q of
|
|
Right Nothing -> []
|
|
Right (Just (_, _, _, xs)) -> xs
|
|
-- this should never fail as regexec always returns Right
|
|
Left _ -> []
|
|
|
|
parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
|
|
parseDecimal (pat, re) s = case matchGroupsMaybe s re of
|
|
[sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x
|
|
[sign, x, y] -> do
|
|
d <- readT "decimal" y
|
|
let p = T.length y
|
|
(k, w) <- readWhole sign x
|
|
return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
|
|
_ -> msg "malformed decimal"
|
|
where
|
|
readT what t = case readMaybe $ T.unpack t of
|
|
Just d -> return $ fromInteger d
|
|
_ -> msg $ T.unwords ["could not parse", what, singleQuote t]
|
|
msg :: MonadFail m => T.Text -> m a
|
|
msg m =
|
|
fail $
|
|
T.unpack $
|
|
T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
|
|
readSign x
|
|
| x == "-" = return (-1)
|
|
| x == "+" || x == "" = return 1
|
|
| otherwise = msg $ T.append "invalid sign: " x
|
|
readWhole sign x = do
|
|
w <- readT "whole number" x
|
|
k <- readSign sign
|
|
return (k, w)
|