diff --git a/app/Main.hs b/app/Main.hs index 2f82c41..7ef6bd7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -163,7 +163,7 @@ runSync c = do sync_ config = migrate_ (sqlConfig config) $ do res <- getDBState config case res of - Left e -> throwIO $ InsertException [e] + Left es -> throwIO $ InsertException es Right s -> flip runReaderT (s $ takeDirectory c) $ do es1 <- insertBudget $ budget config es2 <- insertStatements config diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index c8f46fe..db37438 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -305,13 +305,11 @@ indexAcntRoot r = getDBState :: MonadUnliftIO m => Config - -> SqlPersistT m (EitherErr (FilePath -> DBState)) -getDBState c = mapM (uncurry go) intervals + -> SqlPersistT m (EitherErrs (FilePath -> DBState)) +getDBState c = mapM (uncurry go) $ mapError2 bi si (,) where - intervals = do - b <- intervalMaybeBounds $ budgetInterval $ global c - s <- intervalMaybeBounds $ statementInterval $ global c - return (b, s) + bi = intervalMaybeBounds $ budgetInterval $ global c + si = intervalMaybeBounds $ statementInterval $ global c go budgetInt statementInt = do am <- updateAccounts $ accounts c cm <- updateCurrencies $ currencies c diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index e786552..f39aa68 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -23,6 +23,7 @@ import Dhall.TH import Language.Haskell.TH.Syntax (Lift) import RIO import qualified RIO.Map as M +-- import RIO.State import qualified RIO.Text as T import RIO.Time @@ -526,3 +527,12 @@ newtype InsertException = InsertException [InsertError] deriving (Show) instance Exception InsertException type EitherErr = Either InsertError + +type EitherErrs = Either [InsertError] + +-- type StateErr = State [InsertError] + +-- runErrors :: StateErr a -> Either [InsertError] a +-- runErrors x = case runState x [] of +-- (y, []) -> Right y +-- (_, es) -> Left es diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 17467c4..29f03fb 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -18,7 +18,6 @@ import Text.Regex.TDFA thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f) thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) --- TODO get rid of these errors gregTup :: Gregorian -> EitherErr (Integer, Int, Int) gregTup Gregorian {..} | gYear > 99 = Left $ YearError gYear @@ -85,12 +84,10 @@ valMatches MatchVal {..} x = p = 10 ^ mvPrec s = signum x >= 0 -evalSplit :: TxRecord -> ExpSplit -> EitherErr RawSplit -evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} = do - a_ <- evalAcnt r a - v_ <- mapM (evalExp r) v - c_ <- evalCurrency r c - return (s {sAcnt = a_, sValue = v_, sCurrency = c_}) +evalSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit +evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} = + concatEither3 (evalAcnt r a) (evalCurrency r c) (mapM (evalExp r) v) $ + \a_ c_ v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_}) evalAcnt :: TxRecord -> SplitAcnt -> EitherErr T.Text evalAcnt TxRecord {trOther = o} s = case s of @@ -104,6 +101,7 @@ evalAcnt TxRecord {trOther = o} s = case s of k2 <- lookupErr AccountField f2 o lookupErr AccountField (k1, k2) m +-- TODO wett codde evalCurrency :: TxRecord -> SplitCur -> EitherErr T.Text evalCurrency TxRecord {trOther = o} s = case s of ConstT p -> Right p @@ -119,24 +117,22 @@ evalCurrency TxRecord {trOther = o} s = case s of errorT :: T.Text -> a errorT = error . T.unpack --- lookupField :: (Ord k, Show k) => k -> M.Map k v -> v --- lookupField = lookupErr "field" - lookupErr :: (Ord k, Show k) => LookupField -> k -> M.Map k v -> EitherErr v lookupErr what k m = case M.lookup k m of Just x -> Right x _ -> Left $ LookupError what $ showT k -matches :: Match -> TxRecord -> EitherErr (MatchRes RawTx) +matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx) matches Match {..} r@TxRecord {..} = do - date <- maybe (Right True) (`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 - if date && val && desc && other + res <- concatEither3 date other desc (\x y z -> x && y && z) + if val && res then maybe (Right MatchSkip) (fmap MatchPass . eval) mTx else Right MatchFail where + val = valMatches mVal trAmount + date = maybe (Right True) (`dateMatches` trDate) mDate + other = foldM (\a o -> (a &&) <$> fieldMatches trOther o) True mOther + desc = maybe (return True) (matchMaybe trDesc) mDesc eval (ToTx cur a ss) = toTx cur a ss r matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b @@ -154,25 +150,25 @@ fieldMatches dict m = case m of checkMaybe :: (a -> Bool) -> Maybe a -> Bool checkMaybe = maybe True -toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErr RawTx -toTx sc sa toSplits r@TxRecord {..} = do - a_ <- evalAcnt r sa - c_ <- evalCurrency r sc - ss_ <- mapM (evalSplit r) toSplits - let fromSplit = - Split - { sAcnt = a_ - , sCurrency = c_ - , sValue = Just trAmount - , sComment = "" +toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx +toTx sc sa toSplits r@TxRecord {..} = + concatEithers2 acRes ssRes $ \(a_, c_) ss_ -> + let fromSplit = + Split + { sAcnt = a_ + , sCurrency = c_ + , sValue = Just trAmount + , sComment = "" + } + in Tx + { txTags = [] + , txDate = trDate + , txDescr = trDesc + , txSplits = fromSplit : ss_ } - return $ - Tx - { txTags = [] - , txDate = trDate - , txDescr = trDesc - , txSplits = fromSplit : ss_ - } + where + acRes = concatEither2 (evalAcnt r sa) (evalCurrency r sc) (,) + ssRes = concatEithersL $ fmap (evalSplit r) toSplits parseRational :: MonadFail m => T.Text -> T.Text -> m Rational parseRational pat s = case ms of @@ -207,9 +203,6 @@ parseRational pat s = case ms of k <- readSign sign return (k, w) --- readRationalMsg :: T.Text -> EitherErr Rational --- readRationalMsg t = maybe (Left $ ConversionError t) Right $ readRational t - readRational :: T.Text -> EitherErr Rational readRational s = case T.split (== '.') s of [x] -> maybe err (return . fromInteger) $ readT x @@ -228,11 +221,11 @@ readRational s = case T.split (== '.') s of mapTxSplits :: (a -> b) -> Tx a -> Tx b mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss} -boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErr Bounds -boundsFromGregorian (a, b) = do - a_ <- fromGregorian' a - b_ <- fromGregorian' b - return (a_, b_) +boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErrs Bounds +boundsFromGregorian (a, b) = concatEither2 a_ b_ (,) + where + a_ = fromGregorian' a + b_ = fromGregorian' b fromGregorian' :: Gregorian -> EitherErr Day fromGregorian' = fmap (uncurry3 fromGregorian) . gregTup @@ -243,11 +236,11 @@ inBounds (d0, d1) x = d0 <= x && x <= d1 inMaybeBounds :: MaybeBounds -> Day -> Bool inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1 -intervalMaybeBounds :: Interval -> EitherErr MaybeBounds -intervalMaybeBounds Interval {intStart = s, intEnd = e} = do - s_ <- mapM fromGregorian' s - e_ <- mapM fromGregorian' e - return (s_, e_) +intervalMaybeBounds :: Interval -> EitherErrs MaybeBounds +intervalMaybeBounds Interval {intStart = s, intEnd = e} = concatEither2 s_ e_ (,) + where + s_ = mapM fromGregorian' s + e_ = mapM fromGregorian' e resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds resolveBounds (s, e) = do @@ -386,3 +379,36 @@ keyVal a b = T.concat [a, "=", b] keyVals :: [(T.Text, T.Text)] -> T.Text keyVals = T.intercalate "; " . fmap (uncurry keyVal) + +concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c +concatEither2 a b fun = case (a, b) of + (Right a_, Right b_) -> Right $ fun a_ 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 a b c fun = case (a, b, c) of + (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_ + _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c] + +concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c +concatEithers2 a b = first concat . concatEither2 a b + +concatEithers3 + :: Either [x] a + -> Either [x] b + -> Either [x] c + -> (a -> b -> c -> d) + -> Either [x] d +concatEithers3 a b c = first concat . concatEither3 a b c + +concatEitherL :: [Either x a] -> Either [x] [a] +concatEitherL as = case partitionEithers as of + ([], bs) -> Right bs + (es, _) -> Left es + +concatEithersL :: [Either [x] a] -> Either [x] [a] +concatEithersL = first concat . concatEitherL + +leftToMaybe :: Either a b -> Maybe a +leftToMaybe (Left a) = Just a +leftToMaybe _ = Nothing