ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH use sane error messages when regexps fail

This commit is contained in:
Nathan Dwarshuis 2023-01-06 23:10:44 -05:00
parent 9c45c3f7ea
commit 6b36213a82
3 changed files with 323 additions and 277 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

137
lib/Internal/Statement.hs
View File

@ -24,19 +24,17 @@ import qualified RIO.Vector as V
-- TODO this probably won't scale well (pipes?) -- TODO this probably won't scale well (pipes?)
readImport :: MonadUnliftIO m => Import -> MappingT m [BalTx] readImport :: MonadUnliftIO m => Import -> MappingT m [BalTx]
readImport readImport Import {..} = do
Import rs <- L.sort . concat <$> mapM (readImport_ impSkipLines impDelim impTxOpts) impPaths
{ impPaths = ps case matchRecords impMatches rs of
, impMatches = ms Right (ts, es, notfound) -> do
, impTxOpts = ns liftIO $ mapM_ putStrLn $ reverse es
, impDelim = d liftIO $ mapM_ print notfound
, impSkipLines = n return ts
} = do Left e -> do
rs <- L.sort . concat <$> mapM (readImport_ n d ns) ps liftIO $ print e
let (ts, es, notfound) = matchRecords ms rs -- TODO make sure that a blank list results in a cache reset in the db
liftIO $ mapM_ putStrLn $ reverse es return []
liftIO $ mapM_ print notfound
return ts
readImport_ readImport_
:: MonadUnliftIO m :: MonadUnliftIO m
@ -69,19 +67,19 @@ parseTxRecord TxOpts {..} r = do
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os return $ Just $ TxRecord d' a e os
matchRecords :: [Match] -> [TxRecord] -> ([BalTx], [String], [Match]) matchRecords :: [Match] -> [TxRecord] -> PureErr ([BalTx], [String], [Match])
matchRecords ms rs = matchRecords ms rs = do
( catMaybes ts (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
, T.unpack <$> (es ++ bu) let (es, ts) =
, -- TODO record number of times each match hits for debugging partitionEithers $
notfound fmap Just . balanceTx <$> catMaybes matched
) let bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched
where return
(matched, unmatched, notfound) = matchAll (matchPriorities ms) rs ( catMaybes ts
(es, ts) = , T.unpack <$> (es ++ bu)
partitionEithers $ , -- TODO record number of times each match hits for debugging
fmap Just . balanceTx <$> catMaybes matched notfound
bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched )
matchPriorities :: [Match] -> [MatchGroup] matchPriorities :: [Match] -> [MatchGroup]
matchPriorities = matchPriorities =
@ -129,24 +127,28 @@ zipperSlice f x = go
EQ -> goEq $ Unzipped bs (a : cs) as EQ -> goEq $ Unzipped bs (a : cs) as
LT -> z LT -> z
zipperMatch :: Unzipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx)) zipperMatch :: Unzipped Match -> TxRecord -> PureErr (Zipped Match, MatchRes RawTx)
zipperMatch (Unzipped bs cs as) x = go [] cs zipperMatch (Unzipped bs cs as) x = go [] cs
where where
go _ [] = (Zipped bs $ cs ++ as, Nothing) go _ [] = Right (Zipped bs $ cs ++ as, MatchFail)
go prev (m : ms) = case matches m x of go prev (m : ms) = do
Nothing -> go (m : prev) ms res <- matches m x
res@(Just _) -> case res of
let ps = reverse prev MatchFail -> go (m : prev) ms
ms' = maybe ms (: ms) (matchDec m) skipOrPass ->
in (Zipped bs $ ps ++ ms' ++ as, res) let ps = reverse prev
ms' = maybe ms (: ms) (matchDec m)
in Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
zipperMatch' :: Zipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx)) zipperMatch' :: Zipped Match -> TxRecord -> PureErr (Zipped Match, MatchRes RawTx)
zipperMatch' z x = go z zipperMatch' z x = go z
where where
go (Zipped bs (a : as)) = case matches a x of go (Zipped bs (a : as)) = do
Nothing -> go (Zipped (a : bs) as) res <- matches a x
res -> (Zipped (maybe bs (: bs) $ matchDec a) as, res) case res of
go z' = (z', Nothing) MatchFail -> go (Zipped (a : bs) as)
skipOrPass -> Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
go z' = Right (z', MatchFail)
matchDec :: Match -> Maybe Match matchDec :: Match -> Maybe Match
matchDec m@Match {mTimes = t} = matchDec m@Match {mTimes = t} =
@ -154,46 +156,47 @@ matchDec m@Match {mTimes = t} =
where where
t' = fmap pred t t' = fmap pred t
matchAll :: [MatchGroup] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) matchAll :: [MatchGroup] -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
matchAll = go ([], []) matchAll = go ([], [])
where where
go (matched, unused) gs rs = case (gs, rs) of go (matched, unused) gs rs = case (gs, rs) of
(_, []) -> (matched, [], unused) (_, []) -> return (matched, [], unused)
([], _) -> (matched, rs, unused) ([], _) -> return (matched, rs, unused)
(g : gs', _) -> (g : gs', _) -> do
let (ts, unmatched, us) = matchGroup g rs (ts, unmatched, us) <- matchGroup g rs
in go (ts ++ matched, us ++ unused) gs' unmatched go (ts ++ matched, us ++ unused) gs' unmatched
matchGroup :: MatchGroup -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) matchGroup :: MatchGroup -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
(md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un) (md, rest, ud) <- matchDates ds rs
where (mn, unmatched, un) <- matchNonDates ns rest
(md, rest, ud) = matchDates ds rs return (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
(mn, unmatched, un) = matchNonDates ns rest
matchDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) matchDates :: [Match] -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
matchDates ms = go ([], [], initZipper ms) matchDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z) go (matched, unmatched, z) [] = Right (matched, reverse unmatched, recoverZipper z)
go (matched, unmatched, z) (r : rs) = case zipperSlice findDate r z of go (matched, unmatched, z) (r : rs) = case zipperSlice findDate r z of
Left res -> go (matched, r : unmatched, res) rs Left zipped -> go (matched, r : unmatched, zipped) rs
Right res -> Right unzipped -> do
let (z', p) = zipperMatch res r (z', res) <- zipperMatch unzipped r
(m, u) = case p of let (m, u) = case res of
Just p' -> (p' : matched, unmatched) MatchPass p -> (Just p : matched, unmatched)
Nothing -> (matched, r : unmatched) MatchSkip -> (Nothing : matched, unmatched)
in go (m, u, z') rs 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) $ mDate m
matchNonDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) matchNonDates :: [Match] -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
matchNonDates ms = go ([], [], initZipper ms) matchNonDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z) go (matched, unmatched, z) [] = Right (matched, reverse unmatched, recoverZipper z)
go (matched, unmatched, z) (r : rs) = go (matched, unmatched, z) (r : rs) = do
let (z', res) = zipperMatch' z r (z', res) <- zipperMatch' z r
(m, u) = case res of let (m, u) = case res of
Just x -> (x : matched, unmatched) MatchPass p -> (Just p : matched, unmatched)
Nothing -> (matched, r : unmatched) MatchSkip -> (Nothing : matched, unmatched)
MatchFail -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs in go (m, u, resetZipper z') rs
balanceTx :: RawTx -> Either T.Text BalTx balanceTx :: RawTx -> Either T.Text BalTx

419
lib/Internal/Types.hs
View File

@ -31,52 +31,53 @@ import RIO.Time
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
makeHaskellTypesWith makeHaskellTypesWith
(defaultGenerateOptions{generateToDhallInstance = False}) (defaultGenerateOptions {generateToDhallInstance = False})
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
, MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit" , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
, MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday" , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
, MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat" , MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat"
, MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat" , MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat"
, MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat" , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
, MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD" , MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate" , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum" , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
, MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket" , MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency" , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian" , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM" , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval" , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
, SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global" , SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global"
, SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat" , SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type" , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type" , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
, SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal" , SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
, SingleConstructor "TxOpts" "TxOpts" "(./dhall/Types.dhall).TxOpts.Type" , SingleConstructor "TxOpts" "TxOpts" "(./dhall/Types.dhall).TxOpts.Type"
, SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type" , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
, SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual" , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
, SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax" , SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax"
] ]
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- account tree -- account tree
data AccountTree data AccountTree
= Placeholder T.Text T.Text [AccountTree] = Placeholder T.Text T.Text [AccountTree]
| Account T.Text T.Text | Account T.Text T.Text
TH.makeBaseFunctor ''AccountTree TH.makeBaseFunctor ''AccountTree
deriving instance Generic (AccountTreeF a) deriving instance Generic (AccountTreeF a)
deriving instance FromDhall a => FromDhall (AccountTreeF a) deriving instance FromDhall a => FromDhall (AccountTreeF a)
data AccountRoot_ a = AccountRoot_ data AccountRoot_ a = AccountRoot_
{ arAssets :: ![a] { arAssets :: ![a]
, arEquity :: ![a] , arEquity :: ![a]
, arExpenses :: ![a] , arExpenses :: ![a]
, arIncome :: ![a] , arIncome :: ![a]
, arLiabilities :: ![a] , arLiabilities :: ![a]
} }
deriving (Generic) deriving (Generic)
type AccountRootF = AccountRoot_ (Fix AccountTreeF) type AccountRootF = AccountRoot_ (Fix AccountTreeF)
@ -90,6 +91,7 @@ type AccountRoot = AccountRoot_ AccountTree
deriving instance Eq Currency deriving instance Eq Currency
deriving instance Lift Currency deriving instance Lift Currency
deriving instance Hashable Currency deriving instance Hashable Currency
type CurID = T.Text type CurID = T.Text
@ -99,30 +101,30 @@ type CurID = T.Text
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
data Config_ a = Config_ data Config_ a = Config_
{ global :: !Global { global :: !Global
, budget :: !Budget , budget :: !Budget
, currencies :: ![Currency] , currencies :: ![Currency]
, statements :: ![Statement] , statements :: ![Statement]
, accounts :: !a , accounts :: !a
, sqlConfig :: !SqlConfig , sqlConfig :: !SqlConfig
} }
deriving (Generic) deriving (Generic)
type ConfigF = Config_ AccountRootF type ConfigF = Config_ AccountRootF
type Config = Config_ AccountRoot type Config = Config_ AccountRoot
unfix :: ConfigF -> Config unfix :: ConfigF -> Config
unfix c@Config_{accounts = a} = c{accounts = a'} unfix c@Config_ {accounts = a} = c {accounts = a'}
where where
a' = a' =
AccountRoot_ AccountRoot_
{ arAssets = unfixTree arAssets { arAssets = unfixTree arAssets
, arEquity = unfixTree arEquity , arEquity = unfixTree arEquity
, arExpenses = unfixTree arExpenses , arExpenses = unfixTree arExpenses
, arIncome = unfixTree arIncome , arIncome = unfixTree arIncome
, arLiabilities = unfixTree arLiabilities , arLiabilities = unfixTree arLiabilities
} }
unfixTree f = foldFix embed <$> f a unfixTree f = foldFix embed <$> f a
instance FromDhall a => FromDhall (Config_ a) instance FromDhall a => FromDhall (Config_ a)
@ -140,233 +142,258 @@ deriving instance Eq TimeUnit
deriving instance Hashable TimeUnit deriving instance Hashable TimeUnit
deriving instance Eq Weekday deriving instance Eq Weekday
deriving instance Hashable Weekday deriving instance Hashable Weekday
deriving instance Eq WeekdayPat deriving instance Eq WeekdayPat
deriving instance Hashable WeekdayPat deriving instance Hashable WeekdayPat
deriving instance Show RepeatPat deriving instance Show RepeatPat
deriving instance Eq RepeatPat deriving instance Eq RepeatPat
deriving instance Hashable RepeatPat deriving instance Hashable RepeatPat
deriving instance Show MDYPat deriving instance Show MDYPat
deriving instance Eq MDYPat deriving instance Eq MDYPat
deriving instance Hashable MDYPat deriving instance Hashable MDYPat
deriving instance Eq Gregorian deriving instance Eq Gregorian
deriving instance Show Gregorian deriving instance Show Gregorian
deriving instance Hashable Gregorian deriving instance Hashable Gregorian
deriving instance Eq GregorianM deriving instance Eq GregorianM
deriving instance Show GregorianM deriving instance Show GregorianM
deriving instance Hashable GregorianM deriving instance Hashable GregorianM
-- Dhall.TH rearranges my fields :( -- Dhall.TH rearranges my fields :(
instance Ord Gregorian where instance Ord Gregorian where
compare compare
Gregorian{gYear = y, gMonth = m, gDay = d} Gregorian {gYear = y, gMonth = m, gDay = d}
Gregorian{gYear = y', gMonth = m', gDay = d'} = Gregorian {gYear = y', gMonth = m', gDay = d'} =
compare y y' compare y y'
<> compare m m' <> compare m m'
<> compare d d' <> compare d d'
instance Ord GregorianM where instance Ord GregorianM where
compare compare
GregorianM{gmYear = y, gmMonth = m} GregorianM {gmYear = y, gmMonth = m}
GregorianM{gmYear = y', gmMonth = m'} = compare y y' <> compare m m' GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
deriving instance Eq ModPat deriving instance Eq ModPat
deriving instance Hashable ModPat deriving instance Hashable ModPat
deriving instance Eq CronPat deriving instance Eq CronPat
deriving instance Hashable CronPat deriving instance Hashable CronPat
deriving instance Eq DatePat deriving instance Eq DatePat
deriving instance Hashable DatePat deriving instance Hashable DatePat
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Budget (projecting into the future) -- Budget (projecting into the future)
data Income = Income data Income = Income
{ incGross :: !Decimal { incGross :: !Decimal
, incCurrency :: !CurID , incCurrency :: !CurID
, incWhen :: !DatePat , incWhen :: !DatePat
, incAccount :: !AcntID , incAccount :: !AcntID
, incPretax :: ![Allocation Decimal] , incPretax :: ![Allocation Decimal]
, incTaxes :: ![Tax] , incTaxes :: ![Tax]
, incPosttax :: ![Allocation (Maybe Decimal)] , incPosttax :: ![Allocation (Maybe Decimal)]
} }
deriving (Eq, Hashable, Generic, FromDhall) deriving (Eq, Hashable, Generic, FromDhall)
data Budget = Budget data Budget = Budget
{ income :: ![Income] { income :: ![Income]
, expenses :: ![Expense] , expenses :: ![Expense]
} }
deriving (Generic, FromDhall) deriving (Generic, FromDhall)
deriving instance Eq Tax deriving instance Eq Tax
deriving instance Hashable Tax deriving instance Hashable Tax
data Amount v = Amount data Amount v = Amount
{ amtValue :: !v { amtValue :: !v
, amtDesc :: !T.Text , amtDesc :: !T.Text
} }
deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall) deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall)
data Allocation v = Allocation data Allocation v = Allocation
{ alloPath :: !AcntID { alloPath :: !AcntID
, alloBucket :: !Bucket , alloBucket :: !Bucket
, alloAmts :: ![Amount v] , alloAmts :: ![Amount v]
, alloCurrency :: !CurID , alloCurrency :: !CurID
} }
deriving (Eq, Hashable, Generic, FromDhall) deriving (Eq, Hashable, Generic, FromDhall)
deriving instance Eq Bucket deriving instance Eq Bucket
deriving instance Hashable Bucket deriving instance Hashable Bucket
deriving instance Show Bucket deriving instance Show Bucket
data TimeAmount = TimeAmount data TimeAmount = TimeAmount
{ taWhen :: !DatePat { taWhen :: !DatePat
, taAmt :: Amount Decimal , taAmt :: Amount Decimal
} }
deriving (Eq, Hashable, Generic, FromDhall) deriving (Eq, Hashable, Generic, FromDhall)
data Expense = Expense data Expense = Expense
{ expFrom :: !AcntID { expFrom :: !AcntID
, expTo :: !AcntID , expTo :: !AcntID
, expBucket :: !Bucket , expBucket :: !Bucket
, expAmounts :: ![TimeAmount] , expAmounts :: ![TimeAmount]
, expCurrency :: !CurID , expCurrency :: !CurID
} }
deriving (Eq, Hashable, Generic, FromDhall) deriving (Eq, Hashable, Generic, FromDhall)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Statements (data from the past) -- Statements (data from the past)
data Statement data Statement
= StmtManual Manual = StmtManual Manual
| StmtImport Import | StmtImport Import
deriving (Generic, FromDhall) deriving (Generic, FromDhall)
deriving instance Hashable Manual deriving instance Hashable Manual
data Split a v c = Split data Split a v c = Split
{ sAcnt :: !a { sAcnt :: !a
, sValue :: !v , sValue :: !v
, sCurrency :: !c , sCurrency :: !c
, sComment :: !T.Text , sComment :: !T.Text
} }
deriving (Eq, Generic, Hashable, Show, FromDhall) deriving (Eq, Generic, Hashable, Show, FromDhall)
type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur
data Tx s = Tx data Tx s = Tx
{ txDescr :: !T.Text { txDescr :: !T.Text
, txDate :: !Day , txDate :: !Day
, txTags :: ![T.Text] , txTags :: ![T.Text]
, txSplits :: ![s] , txSplits :: ![s]
} }
deriving (Generic) deriving (Generic)
type ExpTx = Tx ExpSplit type ExpTx = Tx ExpSplit
instance FromDhall ExpTx instance FromDhall ExpTx
data Import = Import data Import = Import
{ impPaths :: ![FilePath] { impPaths :: ![FilePath]
, impMatches :: ![Match] , impMatches :: ![Match]
, impDelim :: !Word , impDelim :: !Word
, impTxOpts :: !TxOpts , impTxOpts :: !TxOpts
, impSkipLines :: !Natural , impSkipLines :: !Natural
} }
deriving (Hashable, Generic, FromDhall) deriving (Hashable, Generic, FromDhall)
deriving instance Eq MatchVal deriving instance Eq MatchVal
deriving instance Hashable MatchVal deriving instance Hashable MatchVal
deriving instance Show MatchVal deriving instance Show MatchVal
deriving instance Eq MatchYMD deriving instance Eq MatchYMD
deriving instance Hashable MatchYMD deriving instance Hashable MatchYMD
deriving instance Show MatchYMD deriving instance Show MatchYMD
deriving instance Eq MatchDate deriving instance Eq MatchDate
deriving instance Hashable MatchDate deriving instance Hashable MatchDate
deriving instance Show MatchDate deriving instance Show MatchDate
-- TODO this just looks silly...but not sure how to simplify it -- TODO this just looks silly...but not sure how to simplify it
instance Ord MatchYMD where instance Ord MatchYMD where
compare (Y y) (Y y') = compare y y' compare (Y y) (Y y') = compare y y'
compare (YM g) (YM g') = compare g g' compare (YM g) (YM g') = compare g g'
compare (YMD g) (YMD g') = compare g g' compare (YMD g) (YMD g') = compare g g'
compare (Y y) (YM g) = compare y (gmYear g) <> LT compare (Y y) (YM g) = compare y (gmYear g) <> LT
compare (Y y) (YMD g) = compare y (gYear g) <> LT compare (Y y) (YMD g) = compare y (gYear g) <> LT
compare (YM g) (Y y') = compare (gmYear g) y' <> GT compare (YM g) (Y y') = compare (gmYear g) y' <> GT
compare (YMD g) (Y y') = compare (gYear g) y' <> GT compare (YMD g) (Y y') = compare (gYear g) y' <> GT
compare (YM g) (YMD g') = compare g (gregM g') <> LT compare (YM g) (YMD g') = compare g (gregM g') <> LT
compare (YMD g) (YM g') = compare (gregM g) g' <> GT compare (YMD g) (YM g') = compare (gregM g) g' <> GT
gregM :: Gregorian -> GregorianM gregM :: Gregorian -> GregorianM
gregM Gregorian{gYear = y, gMonth = m} = gregM Gregorian {gYear = y, gMonth = m} =
GregorianM{gmYear = y, gmMonth = m} GregorianM {gmYear = y, gmMonth = m}
instance Ord MatchDate where instance Ord MatchDate where
compare (On d) (On d') = compare d d' compare (On d) (On d') = compare d d'
compare (In d r) (In d' r') = compare d d' <> compare r r' compare (In d r) (In d' r') = compare d d' <> compare r r'
compare (On d) (In d' _) = compare d d' <> LT compare (On d) (In d' _) = compare d d' <> LT
compare (In d _) (On d') = compare d d' <> GT compare (In d _) (On d') = compare d d' <> GT
deriving instance Eq SplitNum deriving instance Eq SplitNum
deriving instance Hashable SplitNum deriving instance Hashable SplitNum
deriving instance Show SplitNum deriving instance Show SplitNum
{- | 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 SplitText 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 = SplitText CurID
type SplitAcnt = SplitText AcntID type SplitAcnt = SplitText AcntID
data Field k v = Field data Field k v = Field
{ fKey :: !k { fKey :: !k
, fVal :: !v , fVal :: !v
} }
deriving (Show, Eq, Hashable, Generic, FromDhall) deriving (Show, Eq, Hashable, Generic, FromDhall)
type FieldMap k v = Field k (M.Map k v) type FieldMap k v = Field k (M.Map k v)
data MatchOther data MatchOther
= Desc (Field T.Text T.Text) = Desc (Field T.Text T.Text)
| Val (Field T.Text MatchVal) | Val (Field T.Text MatchVal)
deriving (Show, Eq, Hashable, Generic, FromDhall) deriving (Show, Eq, Hashable, Generic, FromDhall)
data ToTx = ToTx data ToTx = ToTx
{ ttCurrency :: !SplitCur { ttCurrency :: !SplitCur
, ttPath :: !SplitAcnt , ttPath :: !SplitAcnt
, ttSplit :: ![ExpSplit] , ttSplit :: ![ExpSplit]
} }
deriving (Eq, Generic, Hashable, Show, FromDhall) deriving (Eq, Generic, Hashable, Show, FromDhall)
data Match = Match data Match = Match
{ mDate :: Maybe MatchDate { mDate :: Maybe MatchDate
, mVal :: MatchVal , mVal :: MatchVal
, mDesc :: Maybe Text , mDesc :: Maybe Text
, mOther :: ![MatchOther] , mOther :: ![MatchOther]
, mTx :: Maybe ToTx , mTx :: Maybe ToTx
, mTimes :: Maybe Natural , mTimes :: Maybe Natural
, mPriority :: !Integer , mPriority :: !Integer
} }
deriving (Eq, Generic, Hashable, Show, FromDhall) deriving (Eq, Generic, Hashable, Show, FromDhall)
deriving instance Eq TxOpts deriving instance Eq TxOpts
deriving instance Hashable TxOpts deriving instance Hashable TxOpts
deriving instance Show TxOpts deriving instance Show TxOpts
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -375,42 +402,43 @@ deriving instance Show TxOpts
deriving instance Eq Decimal deriving instance Eq Decimal
deriving instance Hashable Decimal deriving instance Hashable Decimal
deriving instance Show Decimal deriving instance Show Decimal
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- database cache types -- database cache types
data ConfigHashes = ConfigHashes data ConfigHashes = ConfigHashes
{ chIncome :: ![Int] { chIncome :: ![Int]
, chExpense :: ![Int] , chExpense :: ![Int]
, chManual :: ![Int] , chManual :: ![Int]
, chImport :: ![Int] , chImport :: ![Int]
} }
data ConfigType = CTIncome | CTExpense | CTManual | CTImport data ConfigType = CTIncome | CTExpense | CTManual | CTImport
deriving (Eq, Show, Read, Enum) deriving (Eq, Show, Read, Enum)
instance PersistFieldSql ConfigType where instance PersistFieldSql ConfigType where
sqlType _ = SqlString sqlType _ = SqlString
instance PersistField ConfigType where instance PersistField ConfigType where
toPersistValue = PersistText . T.pack . show toPersistValue = PersistText . T.pack . show
-- TODO these error messages *might* be good enough? -- TODO these error messages *might* be good enough?
fromPersistValue (PersistText v) = fromPersistValue (PersistText v) =
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "wrong type" fromPersistValue _ = Left "wrong type"
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- misc -- misc
data AcntType data AcntType
= AssetT = AssetT
| EquityT | EquityT
| ExpenseT | ExpenseT
| IncomeT | IncomeT
| LiabilityT | LiabilityT
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall) deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
atName :: AcntType -> T.Text atName :: AcntType -> T.Text
atName AssetT = "asset" atName AssetT = "asset"
@ -420,33 +448,33 @@ atName IncomeT = "income"
atName LiabilityT = "liability" atName LiabilityT = "liability"
data AcntPath = AcntPath data AcntPath = AcntPath
{ apType :: !AcntType { apType :: !AcntType
, apChildren :: ![T.Text] , apChildren :: ![T.Text]
} }
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall) deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
data TxRecord = TxRecord data TxRecord = TxRecord
{ trDate :: !Day { trDate :: !Day
, trAmount :: !Rational , trAmount :: !Rational
, trDesc :: !T.Text , trDesc :: !T.Text
, trOther :: M.Map T.Text T.Text , trOther :: M.Map T.Text T.Text
} }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
type Bounds = (Day, Day) type Bounds = (Day, Day)
type MaybeBounds = (Maybe Day, Maybe Day) type MaybeBounds = (Maybe Day, Maybe Day)
data Keyed a = Keyed data Keyed a = Keyed
{ kKey :: !Int64 { kKey :: !Int64
, kVal :: !a , kVal :: !a
} }
deriving (Eq, Show, Functor) deriving (Eq, Show, Functor)
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show) data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
data AcntSign = Credit | Debit data AcntSign = Credit | Debit
deriving (Show) deriving (Show)
sign2Int :: AcntSign -> Int sign2Int :: AcntSign -> Int
sign2Int Debit = 1 sign2Int Debit = 1
@ -472,4 +500,9 @@ type RawSplit = Split AcntID (Maybe Rational) CurID
type BalSplit = Split AcntID Rational CurID type BalSplit = Split AcntID Rational CurID
type RawTx = Tx RawSplit type RawTx = Tx RawSplit
type BalTx = Tx BalSplit type BalTx = Tx BalSplit
type PureErr a = Either T.Text a
data MatchRes a = MatchPass a | MatchFail | MatchSkip

44
lib/Internal/Utils.hs
View File

@ -116,27 +116,32 @@ lookupErr what k m = case M.lookup k m of
Just x -> x Just x -> x
_ -> errorT $ T.concat [what, " does not exist: ", T.pack $ show k] _ -> errorT $ T.concat [what, " does not exist: ", T.pack $ show k]
matches :: Match -> TxRecord -> Maybe (Maybe RawTx) matches :: Match -> TxRecord -> PureErr (MatchRes RawTx)
matches Match {..} r@TxRecord {..} matches Match {..} r@TxRecord {..} = do
| allPass = Just $ fmap eval mTx let date = checkMaybe (`dateMatches` trDate) mDate
| otherwise = Nothing let val = valMatches mVal trAmount
other <- foldM (\a o -> (a &&) <$> fieldMatches trOther o) True mOther
desc <- maybe (return True) (matchMaybe trDesc) mDesc
return $
if date && val && desc && other
then maybe MatchSkip (MatchPass . eval) mTx
else MatchFail
where where
allPass =
checkMaybe (`dateMatches` trDate) mDate
&& valMatches mVal trAmount
&& checkMaybe (=~ trDesc) mDesc
&& all (fieldMatches trOther) mOther
eval (ToTx cur a ss) = toTx cur a ss r eval (ToTx cur a ss) = toTx cur a ss r
-- TODO these error messages are useless matchMaybe :: RegexContext Regex query b => query -> T.Text -> PureErr b
fieldMatches :: M.Map T.Text T.Text -> MatchOther -> Bool matchMaybe q re = first (const msg) $ pureTry $ q =~ re
where
msg = T.concat ["Could not make regexp from pattern: '", re, "'"]
fieldMatches :: M.Map T.Text T.Text -> MatchOther -> PureErr Bool
fieldMatches dict m = case m of fieldMatches dict m = case m of
Val (Field n mv) -> case readRational =<< M.lookup n dict of Val (Field n mv) -> valMatches mv <$> (readRationalMsg =<< lookup_ n)
(Just v) -> valMatches mv v Desc (Field n md) -> (`matchMaybe` md) =<< lookup_ n
_ -> error "you dummy" where
Desc (Field n md) -> case M.lookup n dict of lookup_ n = case M.lookup n dict of
(Just d) -> d =~ md Just r -> Right r
_ -> error "you dummy" Nothing -> Left $ T.append "Could not find field: " n
checkMaybe :: (a -> Bool) -> Maybe a -> Bool checkMaybe :: (a -> Bool) -> Maybe a -> Bool
checkMaybe = maybe True checkMaybe = maybe True
@ -191,6 +196,11 @@ parseRational pat s = case ms of
k <- readSign sign k <- readSign sign
return (k, w) return (k, w)
readRationalMsg :: T.Text -> PureErr Rational
readRationalMsg t = maybe (Left msg) Right $ readRational t
where
msg = T.append "Could not convert to rational number: " t
-- TODO don't use a partial function -- TODO don't use a partial function
readRational :: MonadFail m => T.Text -> m Rational readRational :: MonadFail m => T.Text -> m Rational
readRational s = case TP.splitOn "." s of readRational s = case TP.splitOn "." s of