ENH update haskell types
This commit is contained in:
parent
65a280c3d7
commit
2119eb61c8
|
@ -1,50 +0,0 @@
|
||||||
let List/map =
|
|
||||||
https://prelude.dhall-lang.org/v21.1.0/List/map
|
|
||||||
sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680
|
|
||||||
|
|
||||||
let AccountTree
|
|
||||||
: Type
|
|
||||||
= forall (a : Type) ->
|
|
||||||
forall ( Fix
|
|
||||||
: < AccountF : { _1 : Text, _2 : Text }
|
|
||||||
| PlaceholderF : { _1 : Text, _2 : Text, _3 : List a }
|
|
||||||
> ->
|
|
||||||
a
|
|
||||||
) ->
|
|
||||||
a
|
|
||||||
|
|
||||||
let AccountTreeF =
|
|
||||||
\(a : Type) ->
|
|
||||||
< AccountF : { _1 : Text, _2 : Text }
|
|
||||||
| PlaceholderF : { _1 : Text, _2 : Text, _3 : List a }
|
|
||||||
>
|
|
||||||
|
|
||||||
let Account
|
|
||||||
: Text -> Text -> AccountTree
|
|
||||||
= \(desc : Text) ->
|
|
||||||
\(name : Text) ->
|
|
||||||
\(a : Type) ->
|
|
||||||
let f = AccountTreeF a
|
|
||||||
|
|
||||||
in \(Fix : f -> a) -> Fix (f.AccountF { _1 = desc, _2 = name })
|
|
||||||
|
|
||||||
let Placeholder
|
|
||||||
: Text -> Text -> List AccountTree -> AccountTree
|
|
||||||
= \(desc : Text) ->
|
|
||||||
\(name : Text) ->
|
|
||||||
\(children : List AccountTree) ->
|
|
||||||
\(a : Type) ->
|
|
||||||
let f = AccountTreeF a
|
|
||||||
|
|
||||||
in \(Fix : f -> a) ->
|
|
||||||
let apply = \(x : AccountTree) -> x a Fix
|
|
||||||
|
|
||||||
in Fix
|
|
||||||
( f.PlaceholderF
|
|
||||||
{ _1 = desc
|
|
||||||
, _2 = name
|
|
||||||
, _3 = List/map AccountTree a apply children
|
|
||||||
}
|
|
||||||
)
|
|
||||||
|
|
||||||
in { Account, Placeholder }
|
|
|
@ -98,8 +98,8 @@ hashConfig
|
||||||
} = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
|
} = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
|
||||||
where
|
where
|
||||||
(ms, ps) = partitionEithers $ fmap go ss
|
(ms, ps) = partitionEithers $ fmap go ss
|
||||||
go (StmtManual x) = Left x
|
go (HistTransfer x) = Left x
|
||||||
go (StmtImport x) = Right x
|
go (HistStatement x) = Right x
|
||||||
|
|
||||||
setDiff :: Eq a => [a] -> [a] -> ([a], [a])
|
setDiff :: Eq a => [a] -> [a] -> ([a], [a])
|
||||||
-- setDiff = setDiff' (==)
|
-- setDiff = setDiff' (==)
|
||||||
|
@ -209,7 +209,7 @@ updateTags cs = do
|
||||||
mapM_ insertFull toIns
|
mapM_ insertFull toIns
|
||||||
return $ tagMap tags
|
return $ tagMap tags
|
||||||
where
|
where
|
||||||
toRecord t@(Tag {tagID, tagDesc}) = Entity (toKey t) $ TagR tagID tagDesc
|
toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
|
||||||
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
||||||
|
|
||||||
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
||||||
|
|
|
@ -40,7 +40,7 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
|
||||||
Year -> addGregorianYearsClip
|
Year -> addGregorianYearsClip
|
||||||
|
|
||||||
expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
|
expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
|
||||||
expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
|
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
|
||||||
concatEither3 yRes mRes dRes $ \ys ms ds ->
|
concatEither3 yRes mRes dRes $ \ys ms ds ->
|
||||||
filter validWeekday $
|
filter validWeekday $
|
||||||
mapMaybe (uncurry3 toDay) $
|
mapMaybe (uncurry3 toDay) $
|
||||||
|
@ -48,13 +48,13 @@ expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
|
||||||
dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
|
dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
|
||||||
[(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
|
[(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
|
||||||
where
|
where
|
||||||
yRes = case cronYear of
|
yRes = case cpYear of
|
||||||
Nothing -> return [yb0 .. yb1]
|
Nothing -> return [yb0 .. yb1]
|
||||||
Just pat -> do
|
Just pat -> do
|
||||||
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
|
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
|
||||||
return $ dropWhile (< yb0) $ fromIntegral <$> ys
|
return $ dropWhile (< yb0) $ fromIntegral <$> ys
|
||||||
mRes = expandMD 12 cronMonth
|
mRes = expandMD 12 cpMonth
|
||||||
dRes = expandMD 31 cronDay
|
dRes = expandMD 31 cpDay
|
||||||
(s, e) = expandBounds b
|
(s, e) = expandBounds b
|
||||||
(yb0, mb0, db0) = toGregorian s
|
(yb0, mb0, db0) = toGregorian s
|
||||||
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
|
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
|
||||||
|
@ -63,7 +63,7 @@ expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
|
||||||
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
|
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
|
||||||
expandW (OnDay x) = [fromEnum x]
|
expandW (OnDay x) = [fromEnum x]
|
||||||
expandW (OnDays xs) = fromEnum <$> xs
|
expandW (OnDays xs) = fromEnum <$> xs
|
||||||
ws = maybe [] expandW cronWeekly
|
ws = maybe [] expandW cpWeekly
|
||||||
validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
|
validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
|
||||||
toDay (y, leap) m d
|
toDay (y, leap) m d
|
||||||
| m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
|
| m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
|
||||||
|
@ -120,28 +120,28 @@ withDates dp f = do
|
||||||
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
|
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
|
||||||
insertBudget
|
insertBudget
|
||||||
b@Budget
|
b@Budget
|
||||||
{ budgetLabel
|
{ bgtLabel
|
||||||
, incomes
|
, bgtIncomes
|
||||||
, transfers
|
, bgtTransfers
|
||||||
, shadowTransfers
|
, bgtShadowTransfers
|
||||||
, pretax
|
, bgtPretax
|
||||||
, tax
|
, bgtTax
|
||||||
, posttax
|
, bgtPosttax
|
||||||
} =
|
} =
|
||||||
whenHash CTBudget b [] $ \key -> do
|
whenHash CTBudget b [] $ \key -> do
|
||||||
unlessLefts intAllos $ \intAllos_ -> do
|
unlessLefts intAllos $ \intAllos_ -> do
|
||||||
res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes
|
res1 <- mapM (insertIncome key bgtLabel intAllos_) bgtIncomes
|
||||||
res2 <- expandTransfers key budgetLabel transfers
|
res2 <- expandTransfers key bgtLabel bgtTransfers
|
||||||
unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
|
unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
|
||||||
\txs -> do
|
\txs -> do
|
||||||
unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do
|
unlessLefts (addShadowTransfers bgtShadowTransfers txs) $ \shadow -> do
|
||||||
let bals = balanceTransfers $ txs ++ shadow
|
let bals = balanceTransfers $ txs ++ shadow
|
||||||
concat <$> mapM insertBudgetTx bals
|
concat <$> mapM insertBudgetTx bals
|
||||||
where
|
where
|
||||||
intAllos =
|
intAllos =
|
||||||
let pre_ = sortAllos pretax
|
let pre_ = sortAllos bgtPretax
|
||||||
tax_ = sortAllos tax
|
tax_ = sortAllos bgtTax
|
||||||
post_ = sortAllos posttax
|
post_ = sortAllos bgtPosttax
|
||||||
in concatEithers3 pre_ tax_ post_ (,,)
|
in concatEithers3 pre_ tax_ post_ (,,)
|
||||||
sortAllos = concatEithersL . fmap sortAllo
|
sortAllos = concatEithersL . fmap sortAllo
|
||||||
|
|
||||||
|
@ -201,12 +201,12 @@ fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stTyp
|
||||||
}
|
}
|
||||||
|
|
||||||
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool
|
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool
|
||||||
shadowMatches TransferMatcher {smFrom, smTo, smDate, smVal} tx = do
|
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
|
||||||
valRes <- valMatches smVal $ cvValue $ cbtValue tx
|
valRes <- valMatches tmVal $ cvValue $ cbtValue tx
|
||||||
return $
|
return $
|
||||||
memberMaybe (taAcnt $ cbtFrom tx) smFrom
|
memberMaybe (taAcnt $ cbtFrom tx) tmFrom
|
||||||
&& memberMaybe (taAcnt $ cbtTo tx) smTo
|
&& memberMaybe (taAcnt $ cbtTo tx) tmTo
|
||||||
&& maybe True (`dateMatches` cbtWhen tx) smDate
|
&& maybe True (`dateMatches` cbtWhen tx) tmDate
|
||||||
&& valRes
|
&& valRes
|
||||||
where
|
where
|
||||||
memberMaybe x AcntSet {asList, asInclude} =
|
memberMaybe x AcntSet {asList, asInclude} =
|
||||||
|
@ -354,8 +354,8 @@ allocateTax gross deds = fmap (fmap go)
|
||||||
let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
|
let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
|
||||||
in case tvMethod of
|
in case tvMethod of
|
||||||
TMPercent p -> dec2Rat p * agi
|
TMPercent p -> dec2Rat p * agi
|
||||||
TMBracket TaxProgression {tbsDeductible, tbsBrackets} ->
|
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
||||||
foldBracket (agi - dec2Rat tbsDeductible) tbsBrackets
|
foldBracket (agi - dec2Rat tpDeductible) tpBrackets
|
||||||
|
|
||||||
allocatePost
|
allocatePost
|
||||||
:: Rational
|
:: Rational
|
||||||
|
@ -491,11 +491,11 @@ splitPair from to cur val = case cur of
|
||||||
split c TaggedAcnt {taAcnt, taTags} v =
|
split c TaggedAcnt {taAcnt, taTags} v =
|
||||||
resolveSplit $
|
resolveSplit $
|
||||||
Entry
|
Entry
|
||||||
{ sAcnt = taAcnt
|
{ eAcnt = taAcnt
|
||||||
, sValue = v
|
, eValue = v
|
||||||
, sComment = ""
|
, eComment = ""
|
||||||
, sCurrency = c
|
, eCurrency = c
|
||||||
, sTags = taTags
|
, eTags = taTags
|
||||||
}
|
}
|
||||||
|
|
||||||
checkAcntType
|
checkAcntType
|
||||||
|
@ -578,7 +578,14 @@ txPair
|
||||||
-> m (EitherErrs KeyTx)
|
-> m (EitherErrs KeyTx)
|
||||||
txPair day from to cur val desc = resolveTx tx
|
txPair day from to cur val desc = resolveTx tx
|
||||||
where
|
where
|
||||||
split a v = Entry {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
|
split a v =
|
||||||
|
Entry
|
||||||
|
{ eAcnt = a
|
||||||
|
, eValue = v
|
||||||
|
, eComment = ""
|
||||||
|
, eCurrency = cur
|
||||||
|
, eTags = []
|
||||||
|
}
|
||||||
tx =
|
tx =
|
||||||
Tx
|
Tx
|
||||||
{ txDescr = desc
|
{ txDescr = desc
|
||||||
|
@ -592,21 +599,21 @@ resolveTx t@Tx {txSplits = ss} = do
|
||||||
return $ fmap (\kss -> t {txSplits = kss}) res
|
return $ fmap (\kss -> t {txSplits = kss}) res
|
||||||
|
|
||||||
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
|
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
|
||||||
resolveSplit s@Entry {sAcnt, sCurrency, sValue, sTags} = do
|
resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
|
||||||
aid <- lookupAccountKey sAcnt
|
aid <- lookupAccountKey eAcnt
|
||||||
cid <- lookupCurrency sCurrency
|
cid <- lookupCurrency eCurrency
|
||||||
sign <- lookupAccountSign sAcnt
|
sign <- lookupAccountSign eAcnt
|
||||||
tags <- mapM lookupTag sTags
|
tags <- mapM lookupTag eTags
|
||||||
-- TODO correct sign here?
|
-- TODO correct sign here?
|
||||||
-- TODO lenses would be nice here
|
-- TODO lenses would be nice here
|
||||||
return $
|
return $
|
||||||
concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $
|
concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $
|
||||||
\(aid_, cid_, sign_) tags_ ->
|
\(aid_, cid_, sign_) tags_ ->
|
||||||
s
|
s
|
||||||
{ sAcnt = aid_
|
{ eAcnt = aid_
|
||||||
, sCurrency = cid_
|
, eCurrency = cid_
|
||||||
, sValue = sValue * fromIntegral (sign2Int sign_)
|
, eValue = eValue * fromIntegral (sign2Int sign_)
|
||||||
, sTags = tags_
|
, eTags = tags_
|
||||||
}
|
}
|
||||||
|
|
||||||
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
||||||
|
@ -615,9 +622,9 @@ insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
||||||
mapM_ (insertSplit k) ss
|
mapM_ (insertSplit k) ss
|
||||||
|
|
||||||
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
|
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
|
||||||
insertSplit t Entry {sAcnt, sCurrency, sValue, sComment, sTags} = do
|
insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
|
||||||
k <- insert $ SplitR t sCurrency sAcnt sComment sValue
|
k <- insert $ SplitR t eCurrency eAcnt eComment eValue
|
||||||
mapM_ (insert_ . TagRelationR k) sTags
|
mapM_ (insert_ . TagRelationR k) eTags
|
||||||
return k
|
return k
|
||||||
|
|
||||||
lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
|
lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
|
||||||
|
|
|
@ -21,11 +21,11 @@ import qualified RIO.Vector as V
|
||||||
|
|
||||||
readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx])
|
readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx])
|
||||||
readImport Statement {..} = do
|
readImport Statement {..} = do
|
||||||
let ores = plural $ compileOptions impTxOpts
|
let ores = plural $ compileOptions stmtTxOpts
|
||||||
let cres = concatEithersL $ compileMatch <$> impMatches
|
let cres = concatEithersL $ compileMatch <$> stmtParsers
|
||||||
case concatEithers2 ores cres (,) of
|
case concatEithers2 ores cres (,) of
|
||||||
Right (compiledOptions, compiledMatches) -> do
|
Right (compiledOptions, compiledMatches) -> do
|
||||||
ires <- mapM (readImport_ impSkipLines impDelim compiledOptions) impPaths
|
ires <- mapM (readImport_ stmtSkipLines stmtDelim compiledOptions) stmtPaths
|
||||||
case concatEitherL ires of
|
case concatEitherL ires of
|
||||||
Right records -> return $ matchRecords compiledMatches $ L.sort $ concat records
|
Right records -> return $ matchRecords compiledMatches $ L.sort $ concat records
|
||||||
Left es -> return $ Left es
|
Left es -> return $ Left es
|
||||||
|
@ -75,14 +75,14 @@ matchRecords ms rs = do
|
||||||
matchPriorities :: [MatchRe] -> [MatchGroup]
|
matchPriorities :: [MatchRe] -> [MatchGroup]
|
||||||
matchPriorities =
|
matchPriorities =
|
||||||
fmap matchToGroup
|
fmap matchToGroup
|
||||||
. L.groupBy (\a b -> mPriority a == mPriority b)
|
. L.groupBy (\a b -> spPriority a == spPriority b)
|
||||||
. L.sortOn (Down . mPriority)
|
. L.sortOn (Down . spPriority)
|
||||||
|
|
||||||
matchToGroup :: [MatchRe] -> MatchGroup
|
matchToGroup :: [MatchRe] -> MatchGroup
|
||||||
matchToGroup ms =
|
matchToGroup ms =
|
||||||
uncurry MatchGroup $
|
uncurry MatchGroup $
|
||||||
first (L.sortOn mDate) $
|
first (L.sortOn spDate) $
|
||||||
L.partition (isJust . mDate) ms
|
L.partition (isJust . spDate) ms
|
||||||
|
|
||||||
-- TDOO could use a better struct to flatten the maybe date subtype
|
-- TDOO could use a better struct to flatten the maybe date subtype
|
||||||
data MatchGroup = MatchGroup
|
data MatchGroup = MatchGroup
|
||||||
|
@ -148,9 +148,9 @@ zipperMatch' z x = go z
|
||||||
go z' = Right (z', MatchFail)
|
go z' = Right (z', MatchFail)
|
||||||
|
|
||||||
matchDec :: MatchRe -> Maybe MatchRe
|
matchDec :: MatchRe -> Maybe MatchRe
|
||||||
matchDec m = case mTimes m of
|
matchDec m = case spTimes m of
|
||||||
Just 1 -> Nothing
|
Just 1 -> Nothing
|
||||||
Just n -> Just $ m {mTimes = Just $ n - 1}
|
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||||
Nothing -> Just m
|
Nothing -> Just m
|
||||||
|
|
||||||
matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
||||||
|
@ -167,7 +167,7 @@ matchGroup :: MatchGroup -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [Matc
|
||||||
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
||||||
(md, rest, ud) <- matchDates ds rs
|
(md, rest, ud) <- matchDates ds rs
|
||||||
(mn, unmatched, un) <- matchNonDates ns rest
|
(mn, unmatched, un) <- matchNonDates ns rest
|
||||||
return (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
|
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
||||||
|
|
||||||
matchDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
matchDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
||||||
matchDates ms = go ([], [], initZipper ms)
|
matchDates ms = go ([], [], initZipper ms)
|
||||||
|
@ -188,7 +188,7 @@ matchDates ms = go ([], [], initZipper ms)
|
||||||
MatchSkip -> (Nothing : matched, unmatched)
|
MatchSkip -> (Nothing : matched, unmatched)
|
||||||
MatchFail -> (matched, r : unmatched)
|
MatchFail -> (matched, r : unmatched)
|
||||||
go (m, u, z') rs
|
go (m, u, z') rs
|
||||||
findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
|
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
||||||
|
|
||||||
matchNonDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
matchNonDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
||||||
matchNonDates ms = go ([], [], initZipper ms)
|
matchNonDates ms = go ([], [], initZipper ms)
|
||||||
|
@ -217,14 +217,14 @@ balanceSplits ss =
|
||||||
fmap concat
|
fmap concat
|
||||||
<$> mapM (uncurry bal)
|
<$> mapM (uncurry bal)
|
||||||
$ groupByKey
|
$ groupByKey
|
||||||
$ fmap (\s -> (sCurrency s, s)) ss
|
$ fmap (\s -> (eCurrency s, s)) ss
|
||||||
where
|
where
|
||||||
hasValue s@Entry {sValue = Just v} = Right s {sValue = v}
|
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
||||||
hasValue s = Left s
|
haeValue s = Left s
|
||||||
bal cur rss
|
bal cur rss
|
||||||
| length rss < 2 = Left $ BalanceError TooFewSplits cur rss
|
| length rss < 2 = Left $ BalanceError TooFewSplits cur rss
|
||||||
| otherwise = case partitionEithers $ fmap hasValue rss of
|
| otherwise = case partitionEithers $ fmap haeValue rss of
|
||||||
([noVal], val) -> Right $ noVal {sValue = foldr (\s x -> x - sValue s) 0 val} : val
|
([noVal], val) -> Right $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
|
||||||
([], val) -> Right val
|
([], val) -> Right val
|
||||||
_ -> Left $ BalanceError NotOneBlank cur rss
|
_ -> Left $ BalanceError NotOneBlank cur rss
|
||||||
|
|
||||||
|
|
|
@ -66,7 +66,7 @@ makeHaskellTypesWith
|
||||||
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
|
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
|
||||||
, SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
|
, SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
|
||||||
-- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
|
-- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
|
||||||
-- , SingleConstructor "MatchOther" "MatchOther" "(./dhall/Types.dhall).MatchOther_"
|
-- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_"
|
||||||
-- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
|
-- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
|
||||||
-- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
|
-- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
|
||||||
-- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
|
-- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
|
||||||
|
@ -181,13 +181,13 @@ type BudgetTransfer =
|
||||||
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
|
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
|
||||||
|
|
||||||
data Budget = Budget
|
data Budget = Budget
|
||||||
{ budgetLabel :: Text
|
{ bgtLabel :: Text
|
||||||
, incomes :: [Income]
|
, bgtIncomes :: [Income]
|
||||||
, pretax :: [MultiAllocation PretaxValue]
|
, bgtPretax :: [MultiAllocation PretaxValue]
|
||||||
, tax :: [MultiAllocation TaxValue]
|
, bgtTax :: [MultiAllocation TaxValue]
|
||||||
, posttax :: [MultiAllocation PosttaxValue]
|
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
||||||
, transfers :: [BudgetTransfer]
|
, bgtTransfers :: [BudgetTransfer]
|
||||||
, shadowTransfers :: [ShadowTransfer]
|
, bgtShadowTransfers :: [ShadowTransfer]
|
||||||
}
|
}
|
||||||
|
|
||||||
deriving instance Hashable PretaxValue
|
deriving instance Hashable PretaxValue
|
||||||
|
@ -401,9 +401,9 @@ data History
|
||||||
| HistStatement !Statement
|
| HistStatement !Statement
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
deriving (Eq, Hashable, Generic, FromDhall)
|
||||||
|
|
||||||
type ExpSplit = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
|
type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
|
||||||
|
|
||||||
instance FromDhall ExpSplit
|
instance FromDhall EntryGetter
|
||||||
|
|
||||||
deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
|
deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
|
||||||
|
|
||||||
|
@ -420,7 +420,7 @@ data Tx s = Tx
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
|
||||||
type ExpTx = Tx ExpSplit
|
type ExpTx = Tx EntryGetter
|
||||||
|
|
||||||
instance FromDhall ExpTx
|
instance FromDhall ExpTx
|
||||||
|
|
||||||
|
@ -435,27 +435,27 @@ data TxOpts re = TxOpts
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||||
|
|
||||||
data Statement = Statement
|
data Statement = Statement
|
||||||
{ impPaths :: ![FilePath]
|
{ stmtPaths :: ![FilePath]
|
||||||
, impMatches :: ![Match T.Text]
|
, stmtParsers :: ![StatementParser T.Text]
|
||||||
, impDelim :: !Word
|
, stmtDelim :: !Word
|
||||||
, impTxOpts :: !(TxOpts T.Text)
|
, stmtTxOpts :: !(TxOpts T.Text)
|
||||||
, impSkipLines :: !Natural
|
, stmtSkipLines :: !Natural
|
||||||
}
|
}
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
deriving (Eq, Hashable, Generic, FromDhall)
|
||||||
|
|
||||||
-- | the value of a field in split (text version)
|
-- | the value of a field in split (text version)
|
||||||
-- can either be a raw (constant) value, a lookup from the record, or a map
|
-- can either be a raw (constant) value, a lookup from the record, or a map
|
||||||
-- between the lookup and some other value
|
-- between the lookup and some other value
|
||||||
data SplitText t
|
data EntryTextGetter t
|
||||||
= ConstT !t
|
= ConstT !t
|
||||||
| LookupT !T.Text
|
| LookupT !T.Text
|
||||||
| MapT !(FieldMap T.Text t)
|
| MapT !(FieldMap T.Text t)
|
||||||
| Map2T !(FieldMap (T.Text, T.Text) t)
|
| Map2T !(FieldMap (T.Text, T.Text) t)
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||||
|
|
||||||
type SplitCur = SplitText CurID
|
type SplitCur = EntryTextGetter CurID
|
||||||
|
|
||||||
type SplitAcnt = SplitText AcntID
|
type SplitAcnt = EntryTextGetter AcntID
|
||||||
|
|
||||||
deriving instance (Show k, Show v) => Show (Field k v)
|
deriving instance (Show k, Show v) => Show (Field k v)
|
||||||
|
|
||||||
|
@ -476,32 +476,32 @@ instance Functor (Field f) where
|
||||||
|
|
||||||
type FieldMap k v = Field k (M.Map k v)
|
type FieldMap k v = Field k (M.Map k v)
|
||||||
|
|
||||||
data MatchOther re
|
data FieldMatcher re
|
||||||
= Desc !(Field T.Text re)
|
= Desc !(Field T.Text re)
|
||||||
| Val !(Field T.Text ValMatcher)
|
| Val !(Field T.Text ValMatcher)
|
||||||
deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
|
deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
|
||||||
|
|
||||||
deriving instance Show (MatchOther T.Text)
|
deriving instance Show (FieldMatcher T.Text)
|
||||||
|
|
||||||
data ToTx = ToTx
|
data TxGetter = TxGetter
|
||||||
{ ttCurrency :: !SplitCur
|
{ tgCurrency :: !SplitCur
|
||||||
, ttPath :: !SplitAcnt
|
, tgAcnt :: !SplitAcnt
|
||||||
, ttSplit :: ![ExpSplit]
|
, tgEntries :: ![EntryGetter]
|
||||||
}
|
}
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||||
|
|
||||||
data Match re = Match
|
data StatementParser re = StatementParser
|
||||||
{ mDate :: !(Maybe DateMatcher)
|
{ spDate :: !(Maybe DateMatcher)
|
||||||
, mVal :: !ValMatcher
|
, spVal :: !ValMatcher
|
||||||
, mDesc :: !(Maybe re)
|
, spDesc :: !(Maybe re)
|
||||||
, mOther :: ![MatchOther re]
|
, spOther :: ![FieldMatcher re]
|
||||||
, mTx :: !(Maybe ToTx)
|
, spTx :: !(Maybe TxGetter)
|
||||||
, mTimes :: !(Maybe Natural)
|
, spTimes :: !(Maybe Natural)
|
||||||
, mPriority :: !Integer
|
, spPriority :: !Integer
|
||||||
}
|
}
|
||||||
deriving (Eq, Generic, Hashable, FromDhall, Functor)
|
deriving (Eq, Generic, Hashable, FromDhall, Functor)
|
||||||
|
|
||||||
deriving instance Show (Match T.Text)
|
deriving instance Show (StatementParser T.Text)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- DATABASE MODEL
|
-- DATABASE MODEL
|
||||||
|
@ -753,11 +753,11 @@ data XGregorian = XGregorian
|
||||||
, xgDayOfWeek :: !Int
|
, xgDayOfWeek :: !Int
|
||||||
}
|
}
|
||||||
|
|
||||||
type MatchRe = Match (T.Text, Regex)
|
type MatchRe = StatementParser (T.Text, Regex)
|
||||||
|
|
||||||
type TxOptsRe = TxOpts (T.Text, Regex)
|
type TxOptsRe = TxOpts (T.Text, Regex)
|
||||||
|
|
||||||
type MatchOtherRe = MatchOther (T.Text, Regex)
|
type FieldMatcherRe = FieldMatcher (T.Text, Regex)
|
||||||
|
|
||||||
instance Show (Match (T.Text, Regex)) where
|
instance Show (StatementParser (T.Text, Regex)) where
|
||||||
show = show . fmap fst
|
show = show . fmap fst
|
||||||
|
|
|
@ -155,29 +155,29 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
|
||||||
|
|
||||||
matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
|
matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
|
||||||
matches
|
matches
|
||||||
Match {mTx, mOther, mVal, mDate, mDesc}
|
StatementParser {spTx, spOther, spVal, spDate, spDesc}
|
||||||
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
||||||
res <- concatEither3 val other desc $ \x y z -> x && y && z
|
res <- concatEither3 val other desc $ \x y z -> x && y && z
|
||||||
if date && res
|
if date && res
|
||||||
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
|
then maybe (Right MatchSkip) (fmap MatchPass . convert) spTx
|
||||||
else Right MatchFail
|
else Right MatchFail
|
||||||
where
|
where
|
||||||
val = valMatches mVal trAmount
|
val = valMatches spVal trAmount
|
||||||
date = maybe True (`dateMatches` trDate) mDate
|
date = maybe True (`dateMatches` trDate) spDate
|
||||||
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
|
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
|
||||||
desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
|
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
|
||||||
convert (ToTx cur a ss) = toTx cur a ss r
|
convert (TxGetter cur a ss) = toTx cur a ss r
|
||||||
|
|
||||||
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
|
toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> EitherErrs RawTx
|
||||||
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
|
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
|
||||||
concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
|
concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
|
||||||
let fromSplit =
|
let fromSplit =
|
||||||
Entry
|
Entry
|
||||||
{ sAcnt = a_
|
{ eAcnt = a_
|
||||||
, sCurrency = c_
|
, eCurrency = c_
|
||||||
, sValue = Just trAmount
|
, eValue = Just trAmount
|
||||||
, sComment = ""
|
, eComment = ""
|
||||||
, sTags = [] -- TODO what goes here?
|
, eTags = [] -- TODO what goes here?
|
||||||
}
|
}
|
||||||
in Tx
|
in Tx
|
||||||
{ txDate = trDate
|
{ txDate = trDate
|
||||||
|
@ -189,36 +189,36 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
|
||||||
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
|
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
|
||||||
|
|
||||||
valMatches :: ValMatcher -> Rational -> EitherErr Bool
|
valMatches :: ValMatcher -> Rational -> EitherErr Bool
|
||||||
valMatches ValMatcher {mvDen, mvSign, mvNum, mvPrec} x
|
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
||||||
| Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
|
| Just d_ <- vmDen, d_ >= p = Left $ MatchValPrecisionError d_ p
|
||||||
| otherwise =
|
| otherwise =
|
||||||
Right $
|
Right $
|
||||||
checkMaybe (s ==) mvSign
|
checkMaybe (s ==) vmSign
|
||||||
&& checkMaybe (n ==) mvNum
|
&& checkMaybe (n ==) vmNum
|
||||||
&& checkMaybe ((d * fromIntegral p ==) . fromIntegral) mvDen
|
&& checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen
|
||||||
where
|
where
|
||||||
(n, d) = properFraction $ abs x
|
(n, d) = properFraction $ abs x
|
||||||
p = 10 ^ mvPrec
|
p = 10 ^ vmPrec
|
||||||
s = signum x >= 0
|
s = signum x >= 0
|
||||||
checkMaybe = maybe True
|
checkMaybe = maybe True
|
||||||
|
|
||||||
dateMatches :: DateMatcher -> Day -> Bool
|
dateMatches :: DateMatcher -> Day -> Bool
|
||||||
dateMatches md = (EQ ==) . compareDate md
|
dateMatches md = (EQ ==) . compareDate md
|
||||||
|
|
||||||
otherMatches :: M.Map T.Text T.Text -> MatchOtherRe -> EitherErr Bool
|
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> EitherErr Bool
|
||||||
otherMatches dict m = case m of
|
otherMatches dict m = case m of
|
||||||
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
|
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
|
||||||
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
|
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
|
||||||
where
|
where
|
||||||
lookup_ t n = lookupErr (MatchField t) n dict
|
lookup_ t n = lookupErr (MatchField t) n dict
|
||||||
|
|
||||||
resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
|
resolveSplit :: TxRecord -> EntryGetter -> EitherErrs RawSplit
|
||||||
resolveSplit r s@Entry {sAcnt = a, sValue = v, sCurrency = c} =
|
resolveSplit r s@Entry {eAcnt, eValue, eCurrency} =
|
||||||
concatEithers2 acRes valRes $
|
concatEithers2 acRes valRes $
|
||||||
\(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
|
\(a_, c_) v_ -> (s {eAcnt = a_, eValue = v_, eCurrency = c_})
|
||||||
where
|
where
|
||||||
acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
|
acRes = concatEithers2 (resolveAcnt r eAcnt) (resolveCurrency r eCurrency) (,)
|
||||||
valRes = plural $ mapM (resolveValue r) v
|
valRes = plural $ mapM (resolveValue r) eValue
|
||||||
|
|
||||||
resolveValue :: TxRecord -> EntryNumGetter -> EitherErr Rational
|
resolveValue :: TxRecord -> EntryNumGetter -> EitherErr Rational
|
||||||
resolveValue r s = case s of
|
resolveValue r s = case s of
|
||||||
|
@ -410,18 +410,18 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
|
||||||
]
|
]
|
||||||
|
|
||||||
showMatch :: MatchRe -> T.Text
|
showMatch :: MatchRe -> T.Text
|
||||||
showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriority = p} =
|
showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
|
||||||
T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
|
T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
|
||||||
where
|
where
|
||||||
kvs =
|
kvs =
|
||||||
[ ("date", showDateMatcher <$> d)
|
[ ("date", showDateMatcher <$> spDate)
|
||||||
, ("val", showValMatcher v)
|
, ("val", showValMatcher spVal)
|
||||||
, ("desc", fst <$> e)
|
, ("desc", fst <$> spDesc)
|
||||||
, ("other", others)
|
, ("other", others)
|
||||||
, ("counter", Just $ maybe "Inf" showT n)
|
, ("counter", Just $ maybe "Inf" showT spTimes)
|
||||||
, ("priority", Just $ showT p)
|
, ("priority", Just $ showT spPriority)
|
||||||
]
|
]
|
||||||
others = case o of
|
others = case spOther of
|
||||||
[] -> Nothing
|
[] -> Nothing
|
||||||
xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs
|
xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs
|
||||||
|
|
||||||
|
@ -460,18 +460,18 @@ showYMD_ md =
|
||||||
YMD_ y m d -> [fromIntegral y, m, d]
|
YMD_ y m d -> [fromIntegral y, m, d]
|
||||||
|
|
||||||
showValMatcher :: ValMatcher -> Maybe T.Text
|
showValMatcher :: ValMatcher -> Maybe T.Text
|
||||||
showValMatcher ValMatcher {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
|
showValMatcher ValMatcher {vmSign = Nothing, vmNum = Nothing, vmDen = Nothing} = Nothing
|
||||||
showValMatcher ValMatcher {mvNum, mvDen, mvSign, mvPrec} =
|
showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} =
|
||||||
Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
|
Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
|
||||||
where
|
where
|
||||||
kvs =
|
kvs =
|
||||||
[ ("sign", (\s -> if s then "+" else "-") <$> mvSign)
|
[ ("sign", (\s -> if s then "+" else "-") <$> vmSign)
|
||||||
, ("numerator", showT <$> mvNum)
|
, ("numerator", showT <$> vmNum)
|
||||||
, ("denominator", showT <$> mvDen)
|
, ("denominator", showT <$> vmDen)
|
||||||
, ("precision", Just $ showT mvPrec)
|
, ("precision", Just $ showT vmPrec)
|
||||||
]
|
]
|
||||||
|
|
||||||
showMatchOther :: MatchOtherRe -> T.Text
|
showMatchOther :: FieldMatcherRe -> T.Text
|
||||||
showMatchOther (Desc (Field f (re, _))) =
|
showMatchOther (Desc (Field f (re, _))) =
|
||||||
T.unwords ["desc field", singleQuote f, "with re", singleQuote re]
|
T.unwords ["desc field", singleQuote f, "with re", singleQuote re]
|
||||||
showMatchOther (Val (Field f mv)) =
|
showMatchOther (Val (Field f mv)) =
|
||||||
|
@ -483,11 +483,11 @@ showMatchOther (Val (Field f mv)) =
|
||||||
]
|
]
|
||||||
|
|
||||||
showSplit :: RawSplit -> T.Text
|
showSplit :: RawSplit -> T.Text
|
||||||
showSplit Entry {sAcnt = a, sValue = v, sComment = c} =
|
showSplit Entry {eAcnt, eValue, eComment} =
|
||||||
keyVals
|
keyVals
|
||||||
[ ("account", a)
|
[ ("account", eAcnt)
|
||||||
, ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))
|
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
|
||||||
, ("comment", doubleQuote c)
|
, ("comment", doubleQuote eComment)
|
||||||
]
|
]
|
||||||
|
|
||||||
singleQuote :: T.Text -> T.Text
|
singleQuote :: T.Text -> T.Text
|
||||||
|
@ -621,11 +621,11 @@ compileOptions o@TxOpts {toAmountFmt = pat} = do
|
||||||
re <- compileRegex True pat
|
re <- compileRegex True pat
|
||||||
return $ o {toAmountFmt = re}
|
return $ o {toAmountFmt = re}
|
||||||
|
|
||||||
compileMatch :: Match T.Text -> EitherErrs MatchRe
|
compileMatch :: StatementParser T.Text -> EitherErrs MatchRe
|
||||||
compileMatch m@Match {mDesc = d, mOther = os} = do
|
compileMatch m@StatementParser {spDesc, spOther} = do
|
||||||
let dres = plural $ mapM go d
|
let dres = plural $ mapM go spDesc
|
||||||
let ores = concatEitherL $ fmap (mapM go) os
|
let ores = concatEitherL $ fmap (mapM go) spOther
|
||||||
concatEithers2 dres ores $ \d_ os_ -> m {mDesc = d_, mOther = os_}
|
concatEithers2 dres ores $ \d_ os_ -> m {spDesc = d_, spOther = os_}
|
||||||
where
|
where
|
||||||
go = compileRegex False
|
go = compileRegex False
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue