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)
|
||||
where
|
||||
(ms, ps) = partitionEithers $ fmap go ss
|
||||
go (StmtManual x) = Left x
|
||||
go (StmtImport x) = Right x
|
||||
go (HistTransfer x) = Left x
|
||||
go (HistStatement x) = Right x
|
||||
|
||||
setDiff :: Eq a => [a] -> [a] -> ([a], [a])
|
||||
-- setDiff = setDiff' (==)
|
||||
|
|
@ -209,7 +209,7 @@ updateTags cs = do
|
|||
mapM_ insertFull toIns
|
||||
return $ tagMap tags
|
||||
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))
|
||||
|
||||
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
|
||||
|
||||
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 ->
|
||||
filter validWeekday $
|
||||
mapMaybe (uncurry3 toDay) $
|
||||
|
|
@ -48,13 +48,13 @@ expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
|
|||
dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
|
||||
[(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
|
||||
where
|
||||
yRes = case cronYear of
|
||||
yRes = case cpYear of
|
||||
Nothing -> return [yb0 .. yb1]
|
||||
Just pat -> do
|
||||
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
|
||||
return $ dropWhile (< yb0) $ fromIntegral <$> ys
|
||||
mRes = expandMD 12 cronMonth
|
||||
dRes = expandMD 31 cronDay
|
||||
mRes = expandMD 12 cpMonth
|
||||
dRes = expandMD 31 cpDay
|
||||
(s, e) = expandBounds b
|
||||
(yb0, mb0, db0) = toGregorian s
|
||||
(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)
|
||||
expandW (OnDay x) = [fromEnum x]
|
||||
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
|
||||
toDay (y, leap) m d
|
||||
| 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
|
||||
b@Budget
|
||||
{ budgetLabel
|
||||
, incomes
|
||||
, transfers
|
||||
, shadowTransfers
|
||||
, pretax
|
||||
, tax
|
||||
, posttax
|
||||
{ bgtLabel
|
||||
, bgtIncomes
|
||||
, bgtTransfers
|
||||
, bgtShadowTransfers
|
||||
, bgtPretax
|
||||
, bgtTax
|
||||
, bgtPosttax
|
||||
} =
|
||||
whenHash CTBudget b [] $ \key -> do
|
||||
unlessLefts intAllos $ \intAllos_ -> do
|
||||
res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes
|
||||
res2 <- expandTransfers key budgetLabel transfers
|
||||
res1 <- mapM (insertIncome key bgtLabel intAllos_) bgtIncomes
|
||||
res2 <- expandTransfers key bgtLabel bgtTransfers
|
||||
unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
|
||||
\txs -> do
|
||||
unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do
|
||||
unlessLefts (addShadowTransfers bgtShadowTransfers txs) $ \shadow -> do
|
||||
let bals = balanceTransfers $ txs ++ shadow
|
||||
concat <$> mapM insertBudgetTx bals
|
||||
where
|
||||
intAllos =
|
||||
let pre_ = sortAllos pretax
|
||||
tax_ = sortAllos tax
|
||||
post_ = sortAllos posttax
|
||||
let pre_ = sortAllos bgtPretax
|
||||
tax_ = sortAllos bgtTax
|
||||
post_ = sortAllos bgtPosttax
|
||||
in concatEithers3 pre_ tax_ post_ (,,)
|
||||
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 {smFrom, smTo, smDate, smVal} tx = do
|
||||
valRes <- valMatches smVal $ cvValue $ cbtValue tx
|
||||
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
|
||||
valRes <- valMatches tmVal $ cvValue $ cbtValue tx
|
||||
return $
|
||||
memberMaybe (taAcnt $ cbtFrom tx) smFrom
|
||||
&& memberMaybe (taAcnt $ cbtTo tx) smTo
|
||||
&& maybe True (`dateMatches` cbtWhen tx) smDate
|
||||
memberMaybe (taAcnt $ cbtFrom tx) tmFrom
|
||||
&& memberMaybe (taAcnt $ cbtTo tx) tmTo
|
||||
&& maybe True (`dateMatches` cbtWhen tx) tmDate
|
||||
&& valRes
|
||||
where
|
||||
memberMaybe x AcntSet {asList, asInclude} =
|
||||
|
|
@ -354,8 +354,8 @@ allocateTax gross deds = fmap (fmap go)
|
|||
let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
|
||||
in case tvMethod of
|
||||
TMPercent p -> dec2Rat p * agi
|
||||
TMBracket TaxProgression {tbsDeductible, tbsBrackets} ->
|
||||
foldBracket (agi - dec2Rat tbsDeductible) tbsBrackets
|
||||
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
||||
foldBracket (agi - dec2Rat tpDeductible) tpBrackets
|
||||
|
||||
allocatePost
|
||||
:: Rational
|
||||
|
|
@ -491,11 +491,11 @@ splitPair from to cur val = case cur of
|
|||
split c TaggedAcnt {taAcnt, taTags} v =
|
||||
resolveSplit $
|
||||
Entry
|
||||
{ sAcnt = taAcnt
|
||||
, sValue = v
|
||||
, sComment = ""
|
||||
, sCurrency = c
|
||||
, sTags = taTags
|
||||
{ eAcnt = taAcnt
|
||||
, eValue = v
|
||||
, eComment = ""
|
||||
, eCurrency = c
|
||||
, eTags = taTags
|
||||
}
|
||||
|
||||
checkAcntType
|
||||
|
|
@ -578,7 +578,14 @@ txPair
|
|||
-> m (EitherErrs KeyTx)
|
||||
txPair day from to cur val desc = resolveTx tx
|
||||
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
|
||||
{ txDescr = desc
|
||||
|
|
@ -592,21 +599,21 @@ resolveTx t@Tx {txSplits = ss} = do
|
|||
return $ fmap (\kss -> t {txSplits = kss}) res
|
||||
|
||||
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
|
||||
resolveSplit s@Entry {sAcnt, sCurrency, sValue, sTags} = do
|
||||
aid <- lookupAccountKey sAcnt
|
||||
cid <- lookupCurrency sCurrency
|
||||
sign <- lookupAccountSign sAcnt
|
||||
tags <- mapM lookupTag sTags
|
||||
resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
|
||||
aid <- lookupAccountKey eAcnt
|
||||
cid <- lookupCurrency eCurrency
|
||||
sign <- lookupAccountSign eAcnt
|
||||
tags <- mapM lookupTag eTags
|
||||
-- TODO correct sign here?
|
||||
-- TODO lenses would be nice here
|
||||
return $
|
||||
concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $
|
||||
\(aid_, cid_, sign_) tags_ ->
|
||||
s
|
||||
{ sAcnt = aid_
|
||||
, sCurrency = cid_
|
||||
, sValue = sValue * fromIntegral (sign2Int sign_)
|
||||
, sTags = tags_
|
||||
{ eAcnt = aid_
|
||||
, eCurrency = cid_
|
||||
, eValue = eValue * fromIntegral (sign2Int sign_)
|
||||
, eTags = tags_
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
|
||||
insertSplit t Entry {sAcnt, sCurrency, sValue, sComment, sTags} = do
|
||||
k <- insert $ SplitR t sCurrency sAcnt sComment sValue
|
||||
mapM_ (insert_ . TagRelationR k) sTags
|
||||
insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
|
||||
k <- insert $ SplitR t eCurrency eAcnt eComment eValue
|
||||
mapM_ (insert_ . TagRelationR k) eTags
|
||||
return k
|
||||
|
||||
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 Statement {..} = do
|
||||
let ores = plural $ compileOptions impTxOpts
|
||||
let cres = concatEithersL $ compileMatch <$> impMatches
|
||||
let ores = plural $ compileOptions stmtTxOpts
|
||||
let cres = concatEithersL $ compileMatch <$> stmtParsers
|
||||
case concatEithers2 ores cres (,) of
|
||||
Right (compiledOptions, compiledMatches) -> do
|
||||
ires <- mapM (readImport_ impSkipLines impDelim compiledOptions) impPaths
|
||||
ires <- mapM (readImport_ stmtSkipLines stmtDelim compiledOptions) stmtPaths
|
||||
case concatEitherL ires of
|
||||
Right records -> return $ matchRecords compiledMatches $ L.sort $ concat records
|
||||
Left es -> return $ Left es
|
||||
|
|
@ -75,14 +75,14 @@ matchRecords ms rs = do
|
|||
matchPriorities :: [MatchRe] -> [MatchGroup]
|
||||
matchPriorities =
|
||||
fmap matchToGroup
|
||||
. L.groupBy (\a b -> mPriority a == mPriority b)
|
||||
. L.sortOn (Down . mPriority)
|
||||
. L.groupBy (\a b -> spPriority a == spPriority b)
|
||||
. L.sortOn (Down . spPriority)
|
||||
|
||||
matchToGroup :: [MatchRe] -> MatchGroup
|
||||
matchToGroup ms =
|
||||
uncurry MatchGroup $
|
||||
first (L.sortOn mDate) $
|
||||
L.partition (isJust . mDate) ms
|
||||
first (L.sortOn spDate) $
|
||||
L.partition (isJust . spDate) ms
|
||||
|
||||
-- TDOO could use a better struct to flatten the maybe date subtype
|
||||
data MatchGroup = MatchGroup
|
||||
|
|
@ -148,9 +148,9 @@ zipperMatch' z x = go z
|
|||
go z' = Right (z', MatchFail)
|
||||
|
||||
matchDec :: MatchRe -> Maybe MatchRe
|
||||
matchDec m = case mTimes m of
|
||||
matchDec m = case spTimes m of
|
||||
Just 1 -> Nothing
|
||||
Just n -> Just $ m {mTimes = Just $ n - 1}
|
||||
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||
Nothing -> Just m
|
||||
|
||||
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
|
||||
(md, rest, ud) <- matchDates ds rs
|
||||
(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 ms = go ([], [], initZipper ms)
|
||||
|
|
@ -188,7 +188,7 @@ matchDates ms = go ([], [], initZipper ms)
|
|||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
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 ms = go ([], [], initZipper ms)
|
||||
|
|
@ -217,14 +217,14 @@ balanceSplits ss =
|
|||
fmap concat
|
||||
<$> mapM (uncurry bal)
|
||||
$ groupByKey
|
||||
$ fmap (\s -> (sCurrency s, s)) ss
|
||||
$ fmap (\s -> (eCurrency s, s)) ss
|
||||
where
|
||||
hasValue s@Entry {sValue = Just v} = Right s {sValue = v}
|
||||
hasValue s = Left s
|
||||
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
||||
haeValue 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
|
||||
| otherwise = case partitionEithers $ fmap haeValue rss of
|
||||
([noVal], val) -> Right $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
|
||||
([], val) -> Right val
|
||||
_ -> Left $ BalanceError NotOneBlank cur rss
|
||||
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ makeHaskellTypesWith
|
|||
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
|
||||
, SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
|
||||
-- , 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 "Budget" "Budget" "(./dhall/Types.dhall).Budget"
|
||||
-- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
|
||||
|
|
@ -181,13 +181,13 @@ type BudgetTransfer =
|
|||
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
|
||||
|
||||
data Budget = Budget
|
||||
{ budgetLabel :: Text
|
||||
, incomes :: [Income]
|
||||
, pretax :: [MultiAllocation PretaxValue]
|
||||
, tax :: [MultiAllocation TaxValue]
|
||||
, posttax :: [MultiAllocation PosttaxValue]
|
||||
, transfers :: [BudgetTransfer]
|
||||
, shadowTransfers :: [ShadowTransfer]
|
||||
{ bgtLabel :: Text
|
||||
, bgtIncomes :: [Income]
|
||||
, bgtPretax :: [MultiAllocation PretaxValue]
|
||||
, bgtTax :: [MultiAllocation TaxValue]
|
||||
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
||||
, bgtTransfers :: [BudgetTransfer]
|
||||
, bgtShadowTransfers :: [ShadowTransfer]
|
||||
}
|
||||
|
||||
deriving instance Hashable PretaxValue
|
||||
|
|
@ -401,9 +401,9 @@ data History
|
|||
| HistStatement !Statement
|
||||
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)
|
||||
|
||||
|
|
@ -420,7 +420,7 @@ data Tx s = Tx
|
|||
}
|
||||
deriving (Generic)
|
||||
|
||||
type ExpTx = Tx ExpSplit
|
||||
type ExpTx = Tx EntryGetter
|
||||
|
||||
instance FromDhall ExpTx
|
||||
|
||||
|
|
@ -435,27 +435,27 @@ data TxOpts re = TxOpts
|
|||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
data Statement = Statement
|
||||
{ impPaths :: ![FilePath]
|
||||
, impMatches :: ![Match T.Text]
|
||||
, impDelim :: !Word
|
||||
, impTxOpts :: !(TxOpts T.Text)
|
||||
, impSkipLines :: !Natural
|
||||
{ stmtPaths :: ![FilePath]
|
||||
, stmtParsers :: ![StatementParser T.Text]
|
||||
, stmtDelim :: !Word
|
||||
, stmtTxOpts :: !(TxOpts T.Text)
|
||||
, stmtSkipLines :: !Natural
|
||||
}
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
-- | the value of a field in split (text version)
|
||||
-- can either be a raw (constant) value, a lookup from the record, or a map
|
||||
-- between the lookup and some other value
|
||||
data SplitText t
|
||||
data EntryTextGetter t
|
||||
= ConstT !t
|
||||
| LookupT !T.Text
|
||||
| MapT !(FieldMap T.Text t)
|
||||
| Map2T !(FieldMap (T.Text, T.Text) t)
|
||||
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)
|
||||
|
||||
|
|
@ -476,32 +476,32 @@ instance Functor (Field f) where
|
|||
|
||||
type FieldMap k v = Field k (M.Map k v)
|
||||
|
||||
data MatchOther re
|
||||
data FieldMatcher re
|
||||
= Desc !(Field T.Text re)
|
||||
| Val !(Field T.Text ValMatcher)
|
||||
deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
|
||||
|
||||
deriving instance Show (MatchOther T.Text)
|
||||
deriving instance Show (FieldMatcher T.Text)
|
||||
|
||||
data ToTx = ToTx
|
||||
{ ttCurrency :: !SplitCur
|
||||
, ttPath :: !SplitAcnt
|
||||
, ttSplit :: ![ExpSplit]
|
||||
data TxGetter = TxGetter
|
||||
{ tgCurrency :: !SplitCur
|
||||
, tgAcnt :: !SplitAcnt
|
||||
, tgEntries :: ![EntryGetter]
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
data Match re = Match
|
||||
{ mDate :: !(Maybe DateMatcher)
|
||||
, mVal :: !ValMatcher
|
||||
, mDesc :: !(Maybe re)
|
||||
, mOther :: ![MatchOther re]
|
||||
, mTx :: !(Maybe ToTx)
|
||||
, mTimes :: !(Maybe Natural)
|
||||
, mPriority :: !Integer
|
||||
data StatementParser re = StatementParser
|
||||
{ spDate :: !(Maybe DateMatcher)
|
||||
, spVal :: !ValMatcher
|
||||
, spDesc :: !(Maybe re)
|
||||
, spOther :: ![FieldMatcher re]
|
||||
, spTx :: !(Maybe TxGetter)
|
||||
, spTimes :: !(Maybe Natural)
|
||||
, spPriority :: !Integer
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, FromDhall, Functor)
|
||||
|
||||
deriving instance Show (Match T.Text)
|
||||
deriving instance Show (StatementParser T.Text)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- DATABASE MODEL
|
||||
|
|
@ -753,11 +753,11 @@ data XGregorian = XGregorian
|
|||
, xgDayOfWeek :: !Int
|
||||
}
|
||||
|
||||
type MatchRe = Match (T.Text, Regex)
|
||||
type MatchRe = StatementParser (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
|
||||
|
|
|
|||
|
|
@ -155,29 +155,29 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
|
|||
|
||||
matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
|
||||
matches
|
||||
Match {mTx, mOther, mVal, mDate, mDesc}
|
||||
StatementParser {spTx, spOther, spVal, spDate, spDesc}
|
||||
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
||||
res <- concatEither3 val other desc $ \x y z -> x && y && z
|
||||
if date && res
|
||||
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
|
||||
then maybe (Right MatchSkip) (fmap MatchPass . convert) spTx
|
||||
else Right MatchFail
|
||||
where
|
||||
val = valMatches mVal trAmount
|
||||
date = maybe True (`dateMatches` trDate) mDate
|
||||
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
|
||||
desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
|
||||
convert (ToTx cur a ss) = toTx cur a ss r
|
||||
val = valMatches spVal trAmount
|
||||
date = maybe True (`dateMatches` trDate) spDate
|
||||
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
|
||||
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
|
||||
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} =
|
||||
concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
|
||||
let fromSplit =
|
||||
Entry
|
||||
{ sAcnt = a_
|
||||
, sCurrency = c_
|
||||
, sValue = Just trAmount
|
||||
, sComment = ""
|
||||
, sTags = [] -- TODO what goes here?
|
||||
{ eAcnt = a_
|
||||
, eCurrency = c_
|
||||
, eValue = Just trAmount
|
||||
, eComment = ""
|
||||
, eTags = [] -- TODO what goes here?
|
||||
}
|
||||
in Tx
|
||||
{ txDate = trDate
|
||||
|
|
@ -189,36 +189,36 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
|
|||
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
|
||||
|
||||
valMatches :: ValMatcher -> Rational -> EitherErr Bool
|
||||
valMatches ValMatcher {mvDen, mvSign, mvNum, mvPrec} x
|
||||
| Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
|
||||
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
||||
| Just d_ <- vmDen, d_ >= p = Left $ MatchValPrecisionError d_ p
|
||||
| otherwise =
|
||||
Right $
|
||||
checkMaybe (s ==) mvSign
|
||||
&& checkMaybe (n ==) mvNum
|
||||
&& checkMaybe ((d * fromIntegral p ==) . fromIntegral) mvDen
|
||||
checkMaybe (s ==) vmSign
|
||||
&& checkMaybe (n ==) vmNum
|
||||
&& checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen
|
||||
where
|
||||
(n, d) = properFraction $ abs x
|
||||
p = 10 ^ mvPrec
|
||||
p = 10 ^ vmPrec
|
||||
s = signum x >= 0
|
||||
checkMaybe = maybe True
|
||||
|
||||
dateMatches :: DateMatcher -> Day -> Bool
|
||||
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
|
||||
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
|
||||
|
||||
resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
|
||||
resolveSplit r s@Entry {sAcnt = a, sValue = v, sCurrency = c} =
|
||||
resolveSplit :: TxRecord -> EntryGetter -> EitherErrs RawSplit
|
||||
resolveSplit r s@Entry {eAcnt, eValue, eCurrency} =
|
||||
concatEithers2 acRes valRes $
|
||||
\(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
|
||||
\(a_, c_) v_ -> (s {eAcnt = a_, eValue = v_, eCurrency = c_})
|
||||
where
|
||||
acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
|
||||
valRes = plural $ mapM (resolveValue r) v
|
||||
acRes = concatEithers2 (resolveAcnt r eAcnt) (resolveCurrency r eCurrency) (,)
|
||||
valRes = plural $ mapM (resolveValue r) eValue
|
||||
|
||||
resolveValue :: TxRecord -> EntryNumGetter -> EitherErr Rational
|
||||
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 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]
|
||||
where
|
||||
kvs =
|
||||
[ ("date", showDateMatcher <$> d)
|
||||
, ("val", showValMatcher v)
|
||||
, ("desc", fst <$> e)
|
||||
[ ("date", showDateMatcher <$> spDate)
|
||||
, ("val", showValMatcher spVal)
|
||||
, ("desc", fst <$> spDesc)
|
||||
, ("other", others)
|
||||
, ("counter", Just $ maybe "Inf" showT n)
|
||||
, ("priority", Just $ showT p)
|
||||
, ("counter", Just $ maybe "Inf" showT spTimes)
|
||||
, ("priority", Just $ showT spPriority)
|
||||
]
|
||||
others = case o of
|
||||
others = case spOther of
|
||||
[] -> Nothing
|
||||
xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs
|
||||
|
||||
|
|
@ -460,18 +460,18 @@ showYMD_ md =
|
|||
YMD_ y m d -> [fromIntegral y, m, d]
|
||||
|
||||
showValMatcher :: ValMatcher -> Maybe T.Text
|
||||
showValMatcher ValMatcher {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
|
||||
showValMatcher ValMatcher {mvNum, mvDen, mvSign, mvPrec} =
|
||||
showValMatcher ValMatcher {vmSign = Nothing, vmNum = Nothing, vmDen = Nothing} = Nothing
|
||||
showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} =
|
||||
Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
|
||||
where
|
||||
kvs =
|
||||
[ ("sign", (\s -> if s then "+" else "-") <$> mvSign)
|
||||
, ("numerator", showT <$> mvNum)
|
||||
, ("denominator", showT <$> mvDen)
|
||||
, ("precision", Just $ showT mvPrec)
|
||||
[ ("sign", (\s -> if s then "+" else "-") <$> vmSign)
|
||||
, ("numerator", showT <$> vmNum)
|
||||
, ("denominator", showT <$> vmDen)
|
||||
, ("precision", Just $ showT vmPrec)
|
||||
]
|
||||
|
||||
showMatchOther :: MatchOtherRe -> T.Text
|
||||
showMatchOther :: FieldMatcherRe -> T.Text
|
||||
showMatchOther (Desc (Field f (re, _))) =
|
||||
T.unwords ["desc field", singleQuote f, "with re", singleQuote re]
|
||||
showMatchOther (Val (Field f mv)) =
|
||||
|
|
@ -483,11 +483,11 @@ showMatchOther (Val (Field f mv)) =
|
|||
]
|
||||
|
||||
showSplit :: RawSplit -> T.Text
|
||||
showSplit Entry {sAcnt = a, sValue = v, sComment = c} =
|
||||
showSplit Entry {eAcnt, eValue, eComment} =
|
||||
keyVals
|
||||
[ ("account", a)
|
||||
, ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))
|
||||
, ("comment", doubleQuote c)
|
||||
[ ("account", eAcnt)
|
||||
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
|
||||
, ("comment", doubleQuote eComment)
|
||||
]
|
||||
|
||||
singleQuote :: T.Text -> T.Text
|
||||
|
|
@ -621,11 +621,11 @@ compileOptions o@TxOpts {toAmountFmt = pat} = do
|
|||
re <- compileRegex True pat
|
||||
return $ o {toAmountFmt = re}
|
||||
|
||||
compileMatch :: Match T.Text -> EitherErrs MatchRe
|
||||
compileMatch m@Match {mDesc = d, mOther = os} = do
|
||||
let dres = plural $ mapM go d
|
||||
let ores = concatEitherL $ fmap (mapM go) os
|
||||
concatEithers2 dres ores $ \d_ os_ -> m {mDesc = d_, mOther = os_}
|
||||
compileMatch :: StatementParser T.Text -> EitherErrs MatchRe
|
||||
compileMatch m@StatementParser {spDesc, spOther} = do
|
||||
let dres = plural $ mapM go spDesc
|
||||
let ores = concatEitherL $ fmap (mapM go) spOther
|
||||
concatEithers2 dres ores $ \d_ os_ -> m {spDesc = d_, spOther = os_}
|
||||
where
|
||||
go = compileRegex False
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue