ENH finish make errors not suck

This commit is contained in:
Nathan Dwarshuis 2023-01-28 20:03:58 -05:00
parent f9c1e36ee8
commit d63e1eaa4c
2 changed files with 44 additions and 33 deletions

View File

@ -540,8 +540,8 @@ data AllocationSuberr
data InsertError data InsertError
= RegexError T.Text = RegexError T.Text
| -- | YearError MatchYMD | MatchValPrecisionError Natural Natural
ConversionError T.Text | ConversionError T.Text
| LookupError LookupSuberr T.Text | LookupError LookupSuberr T.Text
| BalanceError BalanceType CurID [RawSplit] | BalanceError BalanceType CurID [RawSplit]
| AllocationError AllocationSuberr DatePat | AllocationError AllocationSuberr DatePat

View File

@ -107,8 +107,8 @@ resolveBounds (s, e) = do
matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx) matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx)
matches Match {..} r@TxRecord {..} = do matches Match {..} r@TxRecord {..} = do
res <- concatEither2 other desc (&&) res <- concatEither3 val other desc $ \x y z -> x && y && z
if date && val && res if date && res
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
else Right MatchFail else Right MatchFail
where where
@ -138,11 +138,14 @@ toTx sc sa toSplits r@TxRecord {..} =
acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,) acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
valMatches :: MatchVal -> Rational -> Bool valMatches :: MatchVal -> Rational -> EitherErr Bool
valMatches MatchVal {..} x = valMatches MatchVal {..} x
checkMaybe (s ==) mvSign | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
&& checkMaybe (n ==) mvNum | otherwise =
&& checkMaybe ((d * p ==) . fromIntegral) mvDen Right $
checkMaybe (s ==) mvSign
&& checkMaybe (n ==) mvNum
&& checkMaybe ((d * fromIntegral p ==) . fromIntegral) mvDen
where where
(n, d) = properFraction $ abs x (n, d) = properFraction $ abs x
p = 10 ^ mvPrec p = 10 ^ mvPrec
@ -154,7 +157,7 @@ dateMatches md = (EQ ==) . compareDate md
otherMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr Bool otherMatches :: M.Map T.Text T.Text -> MatchOther -> 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
@ -277,7 +280,8 @@ showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms)
showError other = (: []) $ case other of showError other = (: []) $ case other of
(RegexError re) -> T.append "could not make regex from pattern: " re (RegexError re) -> T.append "could not make regex from pattern: " re
(ConversionError x) -> T.append "Could not convert to rational number: " x (ConversionError x) -> T.append "Could not convert to rational number: " x
-- TODO use the field indicator (MatchValPrecisionError d p) ->
T.unwords ["Match denominator", showT d, "must be less than", showT p]
(LookupError t f) -> (LookupError t f) ->
T.unwords T.unwords
[ "Could not find field" [ "Could not find field"
@ -318,7 +322,7 @@ showError other = (: []) $ case other of
msg = case t of msg = case t of
TooFewSplits -> "Need at least two splits to balance" TooFewSplits -> "Need at least two splits to balance"
NotOneBlank -> "Exactly one split must be blank" NotOneBlank -> "Exactly one split must be blank"
splits = T.intercalate ", " $ fmap showSplit rss splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
showTx :: TxRecord -> T.Text showTx :: TxRecord -> T.Text
showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} = showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
@ -345,7 +349,7 @@ showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriori
] ]
others = case o of others = case o of
[] -> Nothing [] -> Nothing
xs -> Just $ T.concat $ showMatchOther <$> xs xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs
-- | Convert match date to text -- | Convert match date to text
-- Single date matches will just show the single date, and ranged matches will -- Single date matches will just show the single date, and ranged matches will
@ -381,28 +385,35 @@ showYMD_ md =
YM_ y m -> [fromIntegral y, m] YM_ y m -> [fromIntegral y, m]
YMD_ y m d -> [fromIntegral y, m, d] YMD_ y m d -> [fromIntegral y, m, d]
-- TODO there are errors that can be thrown here
showMatchVal :: MatchVal -> Maybe T.Text showMatchVal :: MatchVal -> Maybe T.Text
showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
showMatchVal MatchVal {..} = Just $ T.concat [sign, num, ".", den] showMatchVal MatchVal {..} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
where where
sign = case mvSign of kvs =
Nothing -> "+/-" [ ("sign", (\s -> if s then "+" else "-") <$> mvSign)
Just s -> if s then "+" else "-" , ("numerator", showT <$> mvNum)
num = maybe "*" showT mvNum , ("denominator", showT <$> mvDen)
den = maybe "*" (lpadT '0' (fromIntegral mvPrec) . showT) mvDen , ("precision", Just $ showT mvPrec)
]
showMatchOther :: MatchOther -> T.Text showMatchOther :: MatchOther -> T.Text
showMatchOther = undefined showMatchOther (Desc (Field f re)) =
T.unwords ["desc field", singleQuote f, "with re", singleQuote re]
showMatchOther (Val (Field f mv)) =
T.unwords
[ "val field"
, singleQuote f
, "with match value"
, singleQuote $ fromMaybe "*" $ showMatchVal mv
]
showSplit :: RawSplit -> T.Text showSplit :: RawSplit -> T.Text
showSplit Split {sAcnt = a, sValue = v, sComment = c} = showSplit Split {sAcnt = a, sValue = v, sComment = c} =
singleQuote $ keyVals
keyVals [ ("account", a)
[ ("account", a) , ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))
, ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float)) , ("comment", doubleQuote c)
, ("comment", doubleQuote c) ]
]
singleQuote :: T.Text -> T.Text singleQuote :: T.Text -> T.Text
singleQuote t = T.concat ["'", t, "'"] singleQuote t = T.concat ["'", t, "'"]
@ -427,10 +438,10 @@ concatEither2 a b fun = case (a, b) of
(Right a_, Right b_) -> Right $ fun a_ b_ (Right a_, Right b_) -> Right $ fun a_ b_
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b] _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
-- concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
-- concatEither3 a b c fun = case (a, b, c) of concatEither3 a b c fun = case (a, b, c) of
-- (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_ (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
-- _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c] _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
concatEithers2 a b = merge . concatEither2 a b concatEithers2 a b = merge . concatEither2 a b
@ -485,8 +496,8 @@ uncurry3 f (a, b, c) = f a b c
-- rpad :: a -> Int -> [a] -> [a] -- rpad :: a -> Int -> [a] -> [a]
-- rpad c n s = s ++ replicate (n - length s) c -- rpad c n s = s ++ replicate (n - length s) c
lpadT :: Char -> Int -> T.Text -> T.Text -- lpadT :: Char -> Int -> T.Text -> T.Text
lpadT c n s = T.append (T.replicate (n - T.length s) (T.singleton c)) s -- lpadT c n s = T.append (T.replicate (n - T.length s) (T.singleton c)) s
matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b
matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re