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) } = (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

View File

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

View File

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

View File

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

View File

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