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
|
||||
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 =
|
||||
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
|
||||
)
|
||||
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
|
||||
|
||||
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 _) ->
|
||||
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 (Zipped bs $ ps ++ ms' ++ as, res)
|
||||
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,7 +31,7 @@ import RIO.Time
|
|||
-------------------------------------------------------------------------------
|
||||
|
||||
makeHaskellTypesWith
|
||||
(defaultGenerateOptions{generateToDhallInstance = False})
|
||||
(defaultGenerateOptions {generateToDhallInstance = False})
|
||||
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
||||
, MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
|
||||
, MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
|
||||
|
|
@ -67,6 +67,7 @@ data AccountTree
|
|||
TH.makeBaseFunctor ''AccountTree
|
||||
|
||||
deriving instance Generic (AccountTreeF a)
|
||||
|
||||
deriving instance FromDhall a => FromDhall (AccountTreeF a)
|
||||
|
||||
data AccountRoot_ a = AccountRoot_
|
||||
|
|
@ -90,6 +91,7 @@ type AccountRoot = AccountRoot_ AccountTree
|
|||
deriving instance Eq Currency
|
||||
|
||||
deriving instance Lift Currency
|
||||
|
||||
deriving instance Hashable Currency
|
||||
|
||||
type CurID = T.Text
|
||||
|
|
@ -113,7 +115,7 @@ 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_
|
||||
|
|
@ -140,48 +142,61 @@ 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'} =
|
||||
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'
|
||||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -205,6 +220,7 @@ data Budget = Budget
|
|||
deriving (Generic, FromDhall)
|
||||
|
||||
deriving instance Eq Tax
|
||||
|
||||
deriving instance Hashable Tax
|
||||
|
||||
data Amount v = Amount
|
||||
|
|
@ -222,7 +238,9 @@ data Allocation v = Allocation
|
|||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
deriving instance Eq Bucket
|
||||
|
||||
deriving instance Hashable Bucket
|
||||
|
||||
deriving instance Show Bucket
|
||||
|
||||
data TimeAmount = TimeAmount
|
||||
|
|
@ -282,15 +300,21 @@ data Import = Import
|
|||
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
|
||||
|
|
@ -306,8 +330,8 @@ instance Ord MatchYMD where
|
|||
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'
|
||||
|
|
@ -316,13 +340,14 @@ instance Ord MatchDate where
|
|||
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
|
||||
|
|
@ -366,7 +391,9 @@ data Match = Match
|
|||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
deriving instance Eq TxOpts
|
||||
|
||||
deriving instance Hashable TxOpts
|
||||
|
||||
deriving instance Show TxOpts
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -375,6 +402,7 @@ deriving instance Show TxOpts
|
|||
deriving instance Eq Decimal
|
||||
|
||||
deriving instance Hashable Decimal
|
||||
|
||||
deriving instance Show Decimal
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -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