ENH use sane error messages when regexps fail
This commit is contained in:
parent
9c45c3f7ea
commit
6b36213a82
|
|
@ -24,19 +24,17 @@ import qualified RIO.Vector as V
|
|||
-- TODO this probably won't scale well (pipes?)
|
||||
|
||||
readImport :: MonadUnliftIO m => Import -> MappingT m [BalTx]
|
||||
readImport
|
||||
Import
|
||||
{ impPaths = ps
|
||||
, impMatches = ms
|
||||
, impTxOpts = ns
|
||||
, impDelim = d
|
||||
, impSkipLines = n
|
||||
} = do
|
||||
rs <- L.sort . concat <$> mapM (readImport_ n d ns) ps
|
||||
let (ts, es, notfound) = matchRecords ms rs
|
||||
liftIO $ mapM_ putStrLn $ reverse es
|
||||
liftIO $ mapM_ print notfound
|
||||
return ts
|
||||
readImport Import {..} = do
|
||||
rs <- L.sort . concat <$> mapM (readImport_ impSkipLines impDelim impTxOpts) impPaths
|
||||
case matchRecords impMatches rs of
|
||||
Right (ts, es, notfound) -> do
|
||||
liftIO $ mapM_ putStrLn $ reverse es
|
||||
liftIO $ mapM_ print notfound
|
||||
return ts
|
||||
Left e -> do
|
||||
liftIO $ print e
|
||||
-- TODO make sure that a blank list results in a cache reset in the db
|
||||
return []
|
||||
|
||||
readImport_
|
||||
:: MonadUnliftIO m
|
||||
|
|
@ -69,19 +67,19 @@ parseTxRecord TxOpts {..} r = do
|
|||
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
||||
return $ Just $ TxRecord d' a e os
|
||||
|
||||
matchRecords :: [Match] -> [TxRecord] -> ([BalTx], [String], [Match])
|
||||
matchRecords ms rs =
|
||||
( catMaybes ts
|
||||
, T.unpack <$> (es ++ bu)
|
||||
, -- TODO record number of times each match hits for debugging
|
||||
notfound
|
||||
)
|
||||
where
|
||||
(matched, unmatched, notfound) = matchAll (matchPriorities ms) rs
|
||||
(es, ts) =
|
||||
partitionEithers $
|
||||
fmap Just . balanceTx <$> catMaybes matched
|
||||
bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched
|
||||
matchRecords :: [Match] -> [TxRecord] -> PureErr ([BalTx], [String], [Match])
|
||||
matchRecords ms rs = do
|
||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||
let (es, ts) =
|
||||
partitionEithers $
|
||||
fmap Just . balanceTx <$> catMaybes matched
|
||||
let bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched
|
||||
return
|
||||
( catMaybes ts
|
||||
, T.unpack <$> (es ++ bu)
|
||||
, -- TODO record number of times each match hits for debugging
|
||||
notfound
|
||||
)
|
||||
|
||||
matchPriorities :: [Match] -> [MatchGroup]
|
||||
matchPriorities =
|
||||
|
|
@ -129,24 +127,28 @@ zipperSlice f x = go
|
|||
EQ -> goEq $ Unzipped bs (a : cs) as
|
||||
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
|
||||
where
|
||||
go _ [] = (Zipped bs $ cs ++ as, Nothing)
|
||||
go prev (m : ms) = case matches m x of
|
||||
Nothing -> go (m : prev) ms
|
||||
res@(Just _) ->
|
||||
let ps = reverse prev
|
||||
ms' = maybe ms (: ms) (matchDec m)
|
||||
in (Zipped bs $ ps ++ ms' ++ as, res)
|
||||
go _ [] = Right (Zipped bs $ cs ++ as, MatchFail)
|
||||
go prev (m : ms) = do
|
||||
res <- matches m x
|
||||
case res of
|
||||
MatchFail -> go (m : prev) ms
|
||||
skipOrPass ->
|
||||
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
|
||||
where
|
||||
go (Zipped bs (a : as)) = case matches a x of
|
||||
Nothing -> go (Zipped (a : bs) as)
|
||||
res -> (Zipped (maybe bs (: bs) $ matchDec a) as, res)
|
||||
go z' = (z', Nothing)
|
||||
go (Zipped bs (a : as)) = do
|
||||
res <- matches a x
|
||||
case res of
|
||||
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 m@Match {mTimes = t} =
|
||||
|
|
@ -154,46 +156,47 @@ matchDec m@Match {mTimes = t} =
|
|||
where
|
||||
t' = fmap pred t
|
||||
|
||||
matchAll :: [MatchGroup] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
|
||||
matchAll :: [MatchGroup] -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
|
||||
matchAll = go ([], [])
|
||||
where
|
||||
go (matched, unused) gs rs = case (gs, rs) of
|
||||
(_, []) -> (matched, [], unused)
|
||||
([], _) -> (matched, rs, unused)
|
||||
(g : gs', _) ->
|
||||
let (ts, unmatched, us) = matchGroup g rs
|
||||
in go (ts ++ matched, us ++ unused) gs' unmatched
|
||||
(_, []) -> return (matched, [], unused)
|
||||
([], _) -> return (matched, rs, unused)
|
||||
(g : gs', _) -> do
|
||||
(ts, unmatched, us) <- matchGroup g rs
|
||||
go (ts ++ matched, us ++ unused) gs' unmatched
|
||||
|
||||
matchGroup :: MatchGroup -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
|
||||
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs =
|
||||
(md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
|
||||
where
|
||||
(md, rest, ud) = matchDates ds rs
|
||||
(mn, unmatched, un) = matchNonDates ns rest
|
||||
matchGroup :: MatchGroup -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
|
||||
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)
|
||||
|
||||
matchDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
|
||||
matchDates :: [Match] -> [TxRecord] -> PureErr ([Maybe RawTx], [TxRecord], [Match])
|
||||
matchDates ms = go ([], [], initZipper ms)
|
||||
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
|
||||
Left res -> go (matched, r : unmatched, res) rs
|
||||
Right res ->
|
||||
let (z', p) = zipperMatch res r
|
||||
(m, u) = case p of
|
||||
Just p' -> (p' : matched, unmatched)
|
||||
Nothing -> (matched, r : unmatched)
|
||||
in go (m, u, z') rs
|
||||
Left zipped -> go (matched, r : unmatched, zipped) rs
|
||||
Right unzipped -> do
|
||||
(z', res) <- zipperMatch unzipped r
|
||||
let (m, u) = case res of
|
||||
MatchPass p -> (Just p : matched, unmatched)
|
||||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
go (m, u, z') rs
|
||||
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)
|
||||
where
|
||||
go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z)
|
||||
go (matched, unmatched, z) (r : rs) =
|
||||
let (z', res) = zipperMatch' z r
|
||||
(m, u) = case res of
|
||||
Just x -> (x : matched, unmatched)
|
||||
Nothing -> (matched, r : unmatched)
|
||||
go (matched, unmatched, z) [] = Right (matched, reverse unmatched, recoverZipper z)
|
||||
go (matched, unmatched, z) (r : rs) = do
|
||||
(z', res) <- zipperMatch' z r
|
||||
let (m, u) = case res of
|
||||
MatchPass p -> (Just p : matched, unmatched)
|
||||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
in go (m, u, resetZipper z') rs
|
||||
|
||||
balanceTx :: RawTx -> Either T.Text BalTx
|
||||
|
|
|
|||
|
|
@ -31,52 +31,53 @@ import RIO.Time
|
|||
-------------------------------------------------------------------------------
|
||||
|
||||
makeHaskellTypesWith
|
||||
(defaultGenerateOptions{generateToDhallInstance = False})
|
||||
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
||||
, MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
|
||||
, MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
|
||||
, MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat"
|
||||
, MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat"
|
||||
, MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
|
||||
, MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
|
||||
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
|
||||
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
|
||||
, MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket"
|
||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
|
||||
, SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global"
|
||||
, SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
|
||||
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
|
||||
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
|
||||
, SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
|
||||
, SingleConstructor "TxOpts" "TxOpts" "(./dhall/Types.dhall).TxOpts.Type"
|
||||
, SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
|
||||
, SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
|
||||
, SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax"
|
||||
]
|
||||
(defaultGenerateOptions {generateToDhallInstance = False})
|
||||
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
||||
, MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
|
||||
, MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
|
||||
, MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat"
|
||||
, MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat"
|
||||
, MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
|
||||
, MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
|
||||
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
|
||||
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
|
||||
, MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket"
|
||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
|
||||
, SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global"
|
||||
, SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
|
||||
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
|
||||
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
|
||||
, SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
|
||||
, SingleConstructor "TxOpts" "TxOpts" "(./dhall/Types.dhall).TxOpts.Type"
|
||||
, SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
|
||||
, SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
|
||||
, SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax"
|
||||
]
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- account tree
|
||||
|
||||
data AccountTree
|
||||
= Placeholder T.Text T.Text [AccountTree]
|
||||
| Account T.Text T.Text
|
||||
= Placeholder T.Text T.Text [AccountTree]
|
||||
| Account T.Text T.Text
|
||||
|
||||
TH.makeBaseFunctor ''AccountTree
|
||||
|
||||
deriving instance Generic (AccountTreeF a)
|
||||
|
||||
deriving instance FromDhall a => FromDhall (AccountTreeF a)
|
||||
|
||||
data AccountRoot_ a = AccountRoot_
|
||||
{ arAssets :: ![a]
|
||||
, arEquity :: ![a]
|
||||
, arExpenses :: ![a]
|
||||
, arIncome :: ![a]
|
||||
, arLiabilities :: ![a]
|
||||
}
|
||||
deriving (Generic)
|
||||
{ arAssets :: ![a]
|
||||
, arEquity :: ![a]
|
||||
, arExpenses :: ![a]
|
||||
, arIncome :: ![a]
|
||||
, arLiabilities :: ![a]
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
|
||||
|
||||
|
|
@ -90,6 +91,7 @@ type AccountRoot = AccountRoot_ AccountTree
|
|||
deriving instance Eq Currency
|
||||
|
||||
deriving instance Lift Currency
|
||||
|
||||
deriving instance Hashable Currency
|
||||
|
||||
type CurID = T.Text
|
||||
|
|
@ -99,30 +101,30 @@ type CurID = T.Text
|
|||
-------------------------------------------------------------------------------
|
||||
|
||||
data Config_ a = Config_
|
||||
{ global :: !Global
|
||||
, budget :: !Budget
|
||||
, currencies :: ![Currency]
|
||||
, statements :: ![Statement]
|
||||
, accounts :: !a
|
||||
, sqlConfig :: !SqlConfig
|
||||
}
|
||||
deriving (Generic)
|
||||
{ global :: !Global
|
||||
, budget :: !Budget
|
||||
, currencies :: ![Currency]
|
||||
, statements :: ![Statement]
|
||||
, accounts :: !a
|
||||
, sqlConfig :: !SqlConfig
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
type ConfigF = Config_ AccountRootF
|
||||
|
||||
type Config = Config_ AccountRoot
|
||||
|
||||
unfix :: ConfigF -> Config
|
||||
unfix c@Config_{accounts = a} = c{accounts = a'}
|
||||
unfix c@Config_ {accounts = a} = c {accounts = a'}
|
||||
where
|
||||
a' =
|
||||
AccountRoot_
|
||||
{ arAssets = unfixTree arAssets
|
||||
, arEquity = unfixTree arEquity
|
||||
, arExpenses = unfixTree arExpenses
|
||||
, arIncome = unfixTree arIncome
|
||||
, arLiabilities = unfixTree arLiabilities
|
||||
}
|
||||
AccountRoot_
|
||||
{ arAssets = unfixTree arAssets
|
||||
, arEquity = unfixTree arEquity
|
||||
, arExpenses = unfixTree arExpenses
|
||||
, arIncome = unfixTree arIncome
|
||||
, arLiabilities = unfixTree arLiabilities
|
||||
}
|
||||
unfixTree f = foldFix embed <$> f a
|
||||
|
||||
instance FromDhall a => FromDhall (Config_ a)
|
||||
|
|
@ -140,233 +142,258 @@ deriving instance Eq TimeUnit
|
|||
deriving instance Hashable TimeUnit
|
||||
|
||||
deriving instance Eq Weekday
|
||||
|
||||
deriving instance Hashable Weekday
|
||||
|
||||
deriving instance Eq WeekdayPat
|
||||
|
||||
deriving instance Hashable WeekdayPat
|
||||
|
||||
deriving instance Show RepeatPat
|
||||
|
||||
deriving instance Eq RepeatPat
|
||||
|
||||
deriving instance Hashable RepeatPat
|
||||
|
||||
deriving instance Show MDYPat
|
||||
|
||||
deriving instance Eq MDYPat
|
||||
|
||||
deriving instance Hashable MDYPat
|
||||
|
||||
deriving instance Eq Gregorian
|
||||
|
||||
deriving instance Show Gregorian
|
||||
|
||||
deriving instance Hashable Gregorian
|
||||
|
||||
deriving instance Eq GregorianM
|
||||
|
||||
deriving instance Show GregorianM
|
||||
|
||||
deriving instance Hashable GregorianM
|
||||
|
||||
-- Dhall.TH rearranges my fields :(
|
||||
instance Ord Gregorian where
|
||||
compare
|
||||
Gregorian{gYear = y, gMonth = m, gDay = d}
|
||||
Gregorian{gYear = y', gMonth = m', gDay = d'} =
|
||||
compare y y'
|
||||
<> compare m m'
|
||||
<> compare d d'
|
||||
compare
|
||||
Gregorian {gYear = y, gMonth = m, gDay = d}
|
||||
Gregorian {gYear = y', gMonth = m', gDay = d'} =
|
||||
compare y y'
|
||||
<> compare m m'
|
||||
<> compare d d'
|
||||
|
||||
instance Ord GregorianM where
|
||||
compare
|
||||
GregorianM{gmYear = y, gmMonth = m}
|
||||
GregorianM{gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
|
||||
compare
|
||||
GregorianM {gmYear = y, gmMonth = m}
|
||||
GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
|
||||
|
||||
deriving instance Eq ModPat
|
||||
|
||||
deriving instance Hashable ModPat
|
||||
|
||||
deriving instance Eq CronPat
|
||||
|
||||
deriving instance Hashable CronPat
|
||||
|
||||
deriving instance Eq DatePat
|
||||
|
||||
deriving instance Hashable DatePat
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Budget (projecting into the future)
|
||||
|
||||
data Income = Income
|
||||
{ incGross :: !Decimal
|
||||
, incCurrency :: !CurID
|
||||
, incWhen :: !DatePat
|
||||
, incAccount :: !AcntID
|
||||
, incPretax :: ![Allocation Decimal]
|
||||
, incTaxes :: ![Tax]
|
||||
, incPosttax :: ![Allocation (Maybe Decimal)]
|
||||
}
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
{ incGross :: !Decimal
|
||||
, incCurrency :: !CurID
|
||||
, incWhen :: !DatePat
|
||||
, incAccount :: !AcntID
|
||||
, incPretax :: ![Allocation Decimal]
|
||||
, incTaxes :: ![Tax]
|
||||
, incPosttax :: ![Allocation (Maybe Decimal)]
|
||||
}
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
data Budget = Budget
|
||||
{ income :: ![Income]
|
||||
, expenses :: ![Expense]
|
||||
}
|
||||
deriving (Generic, FromDhall)
|
||||
{ income :: ![Income]
|
||||
, expenses :: ![Expense]
|
||||
}
|
||||
deriving (Generic, FromDhall)
|
||||
|
||||
deriving instance Eq Tax
|
||||
|
||||
deriving instance Hashable Tax
|
||||
|
||||
data Amount v = Amount
|
||||
{ amtValue :: !v
|
||||
, amtDesc :: !T.Text
|
||||
}
|
||||
deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall)
|
||||
{ amtValue :: !v
|
||||
, amtDesc :: !T.Text
|
||||
}
|
||||
deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
data Allocation v = Allocation
|
||||
{ alloPath :: !AcntID
|
||||
, alloBucket :: !Bucket
|
||||
, alloAmts :: ![Amount v]
|
||||
, alloCurrency :: !CurID
|
||||
}
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
{ alloPath :: !AcntID
|
||||
, alloBucket :: !Bucket
|
||||
, alloAmts :: ![Amount v]
|
||||
, alloCurrency :: !CurID
|
||||
}
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
deriving instance Eq Bucket
|
||||
|
||||
deriving instance Hashable Bucket
|
||||
|
||||
deriving instance Show Bucket
|
||||
|
||||
data TimeAmount = TimeAmount
|
||||
{ taWhen :: !DatePat
|
||||
, taAmt :: Amount Decimal
|
||||
}
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
{ taWhen :: !DatePat
|
||||
, taAmt :: Amount Decimal
|
||||
}
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
data Expense = Expense
|
||||
{ expFrom :: !AcntID
|
||||
, expTo :: !AcntID
|
||||
, expBucket :: !Bucket
|
||||
, expAmounts :: ![TimeAmount]
|
||||
, expCurrency :: !CurID
|
||||
}
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
{ expFrom :: !AcntID
|
||||
, expTo :: !AcntID
|
||||
, expBucket :: !Bucket
|
||||
, expAmounts :: ![TimeAmount]
|
||||
, expCurrency :: !CurID
|
||||
}
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements (data from the past)
|
||||
|
||||
data Statement
|
||||
= StmtManual Manual
|
||||
| StmtImport Import
|
||||
deriving (Generic, FromDhall)
|
||||
= StmtManual Manual
|
||||
| StmtImport Import
|
||||
deriving (Generic, FromDhall)
|
||||
|
||||
deriving instance Hashable Manual
|
||||
|
||||
data Split a v c = Split
|
||||
{ sAcnt :: !a
|
||||
, sValue :: !v
|
||||
, sCurrency :: !c
|
||||
, sComment :: !T.Text
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
{ sAcnt :: !a
|
||||
, sValue :: !v
|
||||
, sCurrency :: !c
|
||||
, sComment :: !T.Text
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur
|
||||
|
||||
data Tx s = Tx
|
||||
{ txDescr :: !T.Text
|
||||
, txDate :: !Day
|
||||
, txTags :: ![T.Text]
|
||||
, txSplits :: ![s]
|
||||
}
|
||||
deriving (Generic)
|
||||
{ txDescr :: !T.Text
|
||||
, txDate :: !Day
|
||||
, txTags :: ![T.Text]
|
||||
, txSplits :: ![s]
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
type ExpTx = Tx ExpSplit
|
||||
|
||||
instance FromDhall ExpTx
|
||||
|
||||
data Import = Import
|
||||
{ impPaths :: ![FilePath]
|
||||
, impMatches :: ![Match]
|
||||
, impDelim :: !Word
|
||||
, impTxOpts :: !TxOpts
|
||||
, impSkipLines :: !Natural
|
||||
}
|
||||
deriving (Hashable, Generic, FromDhall)
|
||||
{ impPaths :: ![FilePath]
|
||||
, impMatches :: ![Match]
|
||||
, impDelim :: !Word
|
||||
, impTxOpts :: !TxOpts
|
||||
, impSkipLines :: !Natural
|
||||
}
|
||||
deriving (Hashable, Generic, FromDhall)
|
||||
|
||||
deriving instance Eq MatchVal
|
||||
|
||||
deriving instance Hashable MatchVal
|
||||
|
||||
deriving instance Show MatchVal
|
||||
|
||||
deriving instance Eq MatchYMD
|
||||
|
||||
deriving instance Hashable MatchYMD
|
||||
|
||||
deriving instance Show MatchYMD
|
||||
|
||||
deriving instance Eq MatchDate
|
||||
|
||||
deriving instance Hashable MatchDate
|
||||
|
||||
deriving instance Show MatchDate
|
||||
|
||||
-- TODO this just looks silly...but not sure how to simplify it
|
||||
instance Ord MatchYMD where
|
||||
compare (Y y) (Y y') = compare y y'
|
||||
compare (YM g) (YM 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) (YMD g) = compare y (gYear g) <> LT
|
||||
compare (YM g) (Y y') = compare (gmYear g) y' <> GT
|
||||
compare (YMD g) (Y y') = compare (gYear g) y' <> GT
|
||||
compare (YM g) (YMD g') = compare g (gregM g') <> LT
|
||||
compare (YMD g) (YM g') = compare (gregM g) g' <> GT
|
||||
compare (Y y) (Y y') = compare y y'
|
||||
compare (YM g) (YM 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) (YMD g) = compare y (gYear g) <> LT
|
||||
compare (YM g) (Y y') = compare (gmYear g) y' <> GT
|
||||
compare (YMD g) (Y y') = compare (gYear g) y' <> GT
|
||||
compare (YM g) (YMD g') = compare g (gregM g') <> LT
|
||||
compare (YMD g) (YM g') = compare (gregM g) g' <> GT
|
||||
|
||||
gregM :: Gregorian -> GregorianM
|
||||
gregM Gregorian{gYear = y, gMonth = m} =
|
||||
GregorianM{gmYear = y, gmMonth = m}
|
||||
gregM Gregorian {gYear = y, gMonth = m} =
|
||||
GregorianM {gmYear = y, gmMonth = m}
|
||||
|
||||
instance Ord MatchDate where
|
||||
compare (On d) (On d') = compare d d'
|
||||
compare (In d r) (In d' r') = compare d d' <> compare r r'
|
||||
compare (On d) (In d' _) = compare d d' <> LT
|
||||
compare (In d _) (On d') = compare d d' <> GT
|
||||
compare (On d) (On d') = compare d d'
|
||||
compare (In d r) (In d' r') = compare d d' <> compare r r'
|
||||
compare (On d) (In d' _) = compare d d' <> LT
|
||||
compare (In d _) (On d') = compare d d' <> GT
|
||||
|
||||
deriving instance Eq SplitNum
|
||||
|
||||
deriving instance Hashable SplitNum
|
||||
|
||||
deriving instance Show SplitNum
|
||||
|
||||
{- | 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
|
||||
-}
|
||||
-- | 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
|
||||
= ConstT !t
|
||||
| LookupT !T.Text
|
||||
| MapT (FieldMap T.Text t)
|
||||
| Map2T (FieldMap (T.Text, T.Text) t)
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
= 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 SplitAcnt = SplitText AcntID
|
||||
|
||||
data Field k v = Field
|
||||
{ fKey :: !k
|
||||
, fVal :: !v
|
||||
}
|
||||
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
||||
{ fKey :: !k
|
||||
, fVal :: !v
|
||||
}
|
||||
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
type FieldMap k v = Field k (M.Map k v)
|
||||
|
||||
data MatchOther
|
||||
= Desc (Field T.Text T.Text)
|
||||
| Val (Field T.Text MatchVal)
|
||||
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
||||
= Desc (Field T.Text T.Text)
|
||||
| Val (Field T.Text MatchVal)
|
||||
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
data ToTx = ToTx
|
||||
{ ttCurrency :: !SplitCur
|
||||
, ttPath :: !SplitAcnt
|
||||
, ttSplit :: ![ExpSplit]
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
{ ttCurrency :: !SplitCur
|
||||
, ttPath :: !SplitAcnt
|
||||
, ttSplit :: ![ExpSplit]
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
data Match = Match
|
||||
{ mDate :: Maybe MatchDate
|
||||
, mVal :: MatchVal
|
||||
, mDesc :: Maybe Text
|
||||
, mOther :: ![MatchOther]
|
||||
, mTx :: Maybe ToTx
|
||||
, mTimes :: Maybe Natural
|
||||
, mPriority :: !Integer
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
{ mDate :: Maybe MatchDate
|
||||
, mVal :: MatchVal
|
||||
, mDesc :: Maybe Text
|
||||
, mOther :: ![MatchOther]
|
||||
, mTx :: Maybe ToTx
|
||||
, mTimes :: Maybe Natural
|
||||
, mPriority :: !Integer
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
deriving instance Eq TxOpts
|
||||
|
||||
deriving instance Hashable TxOpts
|
||||
|
||||
deriving instance Show TxOpts
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -375,42 +402,43 @@ deriving instance Show TxOpts
|
|||
deriving instance Eq Decimal
|
||||
|
||||
deriving instance Hashable Decimal
|
||||
|
||||
deriving instance Show Decimal
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- database cache types
|
||||
|
||||
data ConfigHashes = ConfigHashes
|
||||
{ chIncome :: ![Int]
|
||||
, chExpense :: ![Int]
|
||||
, chManual :: ![Int]
|
||||
, chImport :: ![Int]
|
||||
}
|
||||
{ chIncome :: ![Int]
|
||||
, chExpense :: ![Int]
|
||||
, chManual :: ![Int]
|
||||
, chImport :: ![Int]
|
||||
}
|
||||
|
||||
data ConfigType = CTIncome | CTExpense | CTManual | CTImport
|
||||
deriving (Eq, Show, Read, Enum)
|
||||
deriving (Eq, Show, Read, Enum)
|
||||
|
||||
instance PersistFieldSql ConfigType where
|
||||
sqlType _ = SqlString
|
||||
sqlType _ = SqlString
|
||||
|
||||
instance PersistField ConfigType where
|
||||
toPersistValue = PersistText . T.pack . show
|
||||
toPersistValue = PersistText . T.pack . show
|
||||
|
||||
-- TODO these error messages *might* be good enough?
|
||||
fromPersistValue (PersistText v) =
|
||||
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
||||
fromPersistValue _ = Left "wrong type"
|
||||
-- TODO these error messages *might* be good enough?
|
||||
fromPersistValue (PersistText v) =
|
||||
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
||||
fromPersistValue _ = Left "wrong type"
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- misc
|
||||
|
||||
data AcntType
|
||||
= AssetT
|
||||
| EquityT
|
||||
| ExpenseT
|
||||
| IncomeT
|
||||
| LiabilityT
|
||||
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
|
||||
= AssetT
|
||||
| EquityT
|
||||
| ExpenseT
|
||||
| IncomeT
|
||||
| LiabilityT
|
||||
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
|
||||
|
||||
atName :: AcntType -> T.Text
|
||||
atName AssetT = "asset"
|
||||
|
|
@ -420,33 +448,33 @@ atName IncomeT = "income"
|
|||
atName LiabilityT = "liability"
|
||||
|
||||
data AcntPath = AcntPath
|
||||
{ apType :: !AcntType
|
||||
, apChildren :: ![T.Text]
|
||||
}
|
||||
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
|
||||
{ apType :: !AcntType
|
||||
, apChildren :: ![T.Text]
|
||||
}
|
||||
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
|
||||
|
||||
data TxRecord = TxRecord
|
||||
{ trDate :: !Day
|
||||
, trAmount :: !Rational
|
||||
, trDesc :: !T.Text
|
||||
, trOther :: M.Map T.Text T.Text
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
{ trDate :: !Day
|
||||
, trAmount :: !Rational
|
||||
, trDesc :: !T.Text
|
||||
, trOther :: M.Map T.Text T.Text
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
type Bounds = (Day, Day)
|
||||
|
||||
type MaybeBounds = (Maybe Day, Maybe Day)
|
||||
|
||||
data Keyed a = Keyed
|
||||
{ kKey :: !Int64
|
||||
, kVal :: !a
|
||||
}
|
||||
deriving (Eq, Show, Functor)
|
||||
{ kKey :: !Int64
|
||||
, kVal :: !a
|
||||
}
|
||||
deriving (Eq, Show, Functor)
|
||||
|
||||
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
|
||||
|
||||
data AcntSign = Credit | Debit
|
||||
deriving (Show)
|
||||
deriving (Show)
|
||||
|
||||
sign2Int :: AcntSign -> Int
|
||||
sign2Int Debit = 1
|
||||
|
|
@ -472,4 +500,9 @@ type RawSplit = Split AcntID (Maybe Rational) CurID
|
|||
type BalSplit = Split AcntID Rational CurID
|
||||
|
||||
type RawTx = Tx RawSplit
|
||||
|
||||
type BalTx = Tx BalSplit
|
||||
|
||||
type PureErr a = Either T.Text a
|
||||
|
||||
data MatchRes a = MatchPass a | MatchFail | MatchSkip
|
||||
|
|
|
|||
|
|
@ -116,27 +116,32 @@ lookupErr what k m = case M.lookup k m of
|
|||
Just x -> x
|
||||
_ -> errorT $ T.concat [what, " does not exist: ", T.pack $ show k]
|
||||
|
||||
matches :: Match -> TxRecord -> Maybe (Maybe RawTx)
|
||||
matches Match {..} r@TxRecord {..}
|
||||
| allPass = Just $ fmap eval mTx
|
||||
| otherwise = Nothing
|
||||
matches :: Match -> TxRecord -> PureErr (MatchRes RawTx)
|
||||
matches Match {..} r@TxRecord {..} = do
|
||||
let date = checkMaybe (`dateMatches` trDate) mDate
|
||||
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
|
||||
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
|
||||
|
||||
-- TODO these error messages are useless
|
||||
fieldMatches :: M.Map T.Text T.Text -> MatchOther -> Bool
|
||||
matchMaybe :: RegexContext Regex query b => query -> T.Text -> PureErr b
|
||||
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
|
||||
Val (Field n mv) -> case readRational =<< M.lookup n dict of
|
||||
(Just v) -> valMatches mv v
|
||||
_ -> error "you dummy"
|
||||
Desc (Field n md) -> case M.lookup n dict of
|
||||
(Just d) -> d =~ md
|
||||
_ -> error "you dummy"
|
||||
Val (Field n mv) -> valMatches mv <$> (readRationalMsg =<< lookup_ n)
|
||||
Desc (Field n md) -> (`matchMaybe` md) =<< lookup_ n
|
||||
where
|
||||
lookup_ n = case M.lookup n dict of
|
||||
Just r -> Right r
|
||||
Nothing -> Left $ T.append "Could not find field: " n
|
||||
|
||||
checkMaybe :: (a -> Bool) -> Maybe a -> Bool
|
||||
checkMaybe = maybe True
|
||||
|
|
@ -191,6 +196,11 @@ parseRational pat s = case ms of
|
|||
k <- readSign sign
|
||||
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
|
||||
readRational :: MonadFail m => T.Text -> m Rational
|
||||
readRational s = case TP.splitOn "." s of
|
||||
|
|
|
|||
Loading…
Reference in New Issue