ENH update haskell types

This commit is contained in:
Nathan Dwarshuis 2023-04-30 23:28:16 -04:00
parent 65a280c3d7
commit 2119eb61c8
6 changed files with 154 additions and 197 deletions

View File

@ -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 }

View File

@ -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

View File

@ -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))

View File

@ -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

View File

@ -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

View File

@ -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