diff --git a/dhall/Accounts.dhall b/dhall/Accounts.dhall deleted file mode 100644 index 7b42b72..0000000 --- a/dhall/Accounts.dhall +++ /dev/null @@ -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 } diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 54aeac0..11bb000 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -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 diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index ed7b945..13a9cf9 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -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)) diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index cd9180e..aeaf133 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -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 diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 6526cb7..d76f539 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -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 diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 873f5f1..ddfb701 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -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