diff --git a/app/Main.hs b/app/Main.hs index fdeeb18..2f82c41 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -158,13 +158,16 @@ runSync :: MonadUnliftIO m => FilePath -> m () runSync c = do config <- readConfig c catch (sync_ config) $ \case - MatchException -> liftIO $ putStrLn "match error" - RegexException -> liftIO $ putStrLn "regex error" + InsertException _ -> liftIO $ putStrLn "insert error" where sync_ config = migrate_ (sqlConfig config) $ do - s <- getDBState config - flip runReaderT (s $ takeDirectory c) $ do - insertBudget $ budget config - insertStatements config + res <- getDBState config + case res of + Left e -> throwIO $ InsertException [e] + Right s -> flip runReaderT (s $ takeDirectory c) $ do + es1 <- insertBudget $ budget config + es2 <- insertStatements config + let es = es1 ++ es2 + unless (null es) $ throwIO $ InsertException es -- showBalances diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index b0623b4..c8f46fe 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -302,19 +302,28 @@ indexAcntRoot r = where (ars, aprs, ms) = unzip3 $ uncurry tree2Records <$> flattenAcntRoot r -getDBState :: MonadUnliftIO m => Config -> SqlPersistT m (FilePath -> DBState) -getDBState c = do - am <- updateAccounts $ accounts c - cm <- updateCurrencies $ currencies c - hs <- updateHashes c - -- TODO not sure how I feel about this, probably will change this struct alot - -- in the future so whatever...for now - return $ \f -> - DBState - { kmCurrency = cm - , kmAccount = am - , kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c - , kmStatementInterval = intervalMaybeBounds $ statementInterval $ global c - , kmNewCommits = hs - , kmConfigDir = f - } +getDBState + :: MonadUnliftIO m + => Config + -> SqlPersistT m (EitherErr (FilePath -> DBState)) +getDBState c = mapM (uncurry go) intervals + where + intervals = do + b <- intervalMaybeBounds $ budgetInterval $ global c + s <- intervalMaybeBounds $ statementInterval $ global c + return (b, s) + go budgetInt statementInt = do + am <- updateAccounts $ accounts c + cm <- updateCurrencies $ currencies c + hs <- updateHashes c + -- TODO not sure how I feel about this, probably will change this struct alot + -- in the future so whatever...for now + return $ \f -> + DBState + { kmCurrency = cm + , kmAccount = am + , kmBudgetInterval = budgetInt + , kmStatementInterval = statementInt + , kmNewCommits = hs + , kmConfigDir = f + } diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index dc4c7f8..dd73662 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -48,24 +48,21 @@ lookupCurrency c = do -------------------------------------------------------------------------------- -- intervals -expandDatePat :: Bounds -> DatePat -> [Day] -expandDatePat (a, b) (Cron cp) = filter (cronPatternMatches cp) [a .. b] +expandDatePat :: Bounds -> DatePat -> EitherErr [Day] +expandDatePat (a, b) (Cron cp) = return $ filter (cronPatternMatches cp) [a .. b] expandDatePat i (Mod mp) = expandModPat mp i -expandModPat :: ModPat -> Bounds -> [Day] +expandModPat :: ModPat -> Bounds -> EitherErr [Day] expandModPat - ModPat - { mpStart = s - , mpBy = b - , mpUnit = u - , mpRepeats = r - } - (lower, upper) = - takeWhile (<= upper) $ - (`addFun` start) . (* b') - <$> maybe id (take . fromIntegral) r [0 ..] + ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} + (lower, upper) = do + start <- maybe (return lower) fromGregorian' s + return $ + takeWhile (<= upper) $ + (`addFun` start) . (* b') + <$> maybe id (take . fromIntegral) r [0 ..] where - start = maybe lower fromGregorian' s + -- start = maybe lower fromGregorian' s b' = fromIntegral b addFun = case u of Day -> addDays @@ -121,10 +118,11 @@ mdyPatternMatches check x p = case p of -------------------------------------------------------------------------------- -- budget -insertBudget :: MonadUnliftIO m => Budget -> MappingT m () +insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError] insertBudget Budget {income = is, expenses = es} = do - mapM_ insertIncome is - mapM_ insertExpense es + es1 <- mapM insertIncome is + es2 <- mapM insertExpense es + return $ catMaybes es1 ++ concat es2 -- TODO this hashes twice (not that it really matters) whenHash @@ -139,7 +137,7 @@ whenHash t o def f = do hs <- asks kmNewCommits if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def -insertIncome :: MonadUnliftIO m => Income -> MappingT m () +insertIncome :: MonadUnliftIO m => Income -> MappingT m (Maybe InsertError) insertIncome i@Income { incCurrency = cur @@ -147,15 +145,19 @@ insertIncome , incAccount = from , incTaxes = ts } = - whenHash CTIncome i () $ \c -> do + whenHash CTIncome i Nothing $ \c -> do case balanceIncome i of - Left m -> liftIO $ print m + Left m -> liftIO $ print m >> return Nothing Right as -> do bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval - forM_ (expandDatePat bounds dp) $ \day -> do - alloTx <- concat <$> mapM (allocationToTx from day) as - taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts - lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx + case expandDatePat bounds dp of + Left e -> return $ Just e + Right days -> do + forM_ days $ \day -> do + alloTx <- concat <$> mapM (allocationToTx from day) as + taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts + lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx + return Nothing balanceIncome :: Income -> Either T.Text [BalAllocation] balanceIncome @@ -234,7 +236,7 @@ transferToTx transferToTx day from to cur Amount {amtValue = v, amtDesc = d} = txPair day from to cur v d -insertExpense :: MonadUnliftIO m => Expense -> MappingT m () +insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError] insertExpense e@Expense { expFrom = from @@ -243,17 +245,23 @@ insertExpense , expBucket = buc , expAmounts = as } = do - whenHash CTExpense e () $ \c -> do - ts <- concat <$> mapM (timeAmountToTx from to cur) as - lift $ mapM_ (insertTxBucket (Just buc) c) ts + whenHash CTExpense e [] $ \key -> catMaybes <$> mapM (go key) as + where + go key amt = do + res <- timeAmountToTx from to cur amt + case res of + Left err -> return $ Just err + Right txs -> do + lift $ mapM_ (insertTxBucket (Just buc) key) txs + return Nothing timeAmountToTx :: MonadUnliftIO m => AcntID -> AcntID - -> T.Text + -> CurID -> TimeAmount - -> MappingT m [KeyTx] + -> MappingT m (EitherErr [KeyTx]) timeAmountToTx from to @@ -267,23 +275,25 @@ timeAmountToTx } } = do bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval - mapM tx $ expandDatePat bounds dp + case expandDatePat bounds dp of + Left e -> return $ Left e + Right days -> Right <$> mapM tx days where tx day = txPair day from to cur (dec2Rat v) d -------------------------------------------------------------------------------- -- statements -insertStatements :: MonadUnliftIO m => Config -> MappingT m () -insertStatements conf = do - es <- catMaybes <$> mapM insertStatement (statements conf) - unless (null es) $ throwIO $ InsertException es +insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError] +insertStatements conf = catMaybes <$> mapM insertStatement (statements conf) + +-- unless (null es) $ throwIO $ InsertException es insertStatement :: MonadUnliftIO m => Statement -> MappingT m (Maybe InsertError) -insertStatement (StmtManual m) = insertManual m >> return Nothing +insertStatement (StmtManual m) = insertManual m insertStatement (StmtImport i) = insertImport i -insertManual :: MonadUnliftIO m => Manual -> MappingT m () +insertManual :: MonadUnliftIO m => Manual -> MappingT m (Maybe InsertError) insertManual m@Manual { manualDate = dp @@ -293,10 +303,14 @@ insertManual , manualCurrency = u , manualDesc = e } = do - whenHash CTManual m () $ \c -> do + whenHash CTManual m Nothing $ \c -> do bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval - ts <- mapM tx $ expandDatePat bounds dp - lift $ mapM_ (insertTx c) ts + case expandDatePat bounds dp of + Left err -> return $ Just err + Right days -> do + ts <- mapM tx days + lift $ mapM_ (insertTx c) ts + return Nothing where tx day = txPair day from to u (dec2Rat v) e diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index ae6362b..5d42b3d 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -100,19 +100,23 @@ resetZipper = initZipper . recoverZipper recoverZipper :: Zipped a -> [a] recoverZipper (Zipped as bs) = reverse as ++ bs -zipperSlice :: (a -> b -> Ordering) -> b -> Zipped a -> Either (Zipped a) (Unzipped a) +zipperSlice :: Monad m => (a -> b -> m Ordering) -> b -> Zipped a -> m (Either (Zipped a) (Unzipped a)) zipperSlice f x = go where - go z@(Zipped _ []) = Left z - go z@(Zipped bs (a : as)) = case f a x of - GT -> go $ Zipped (a : bs) as - EQ -> Right $ goEq (Unzipped bs [a] as) - LT -> Left z - goEq z@(Unzipped _ _ []) = z - goEq z@(Unzipped bs cs (a : as)) = case f a x of - GT -> goEq $ Unzipped (a : bs) cs as - EQ -> goEq $ Unzipped bs (a : cs) as - LT -> z + go z@(Zipped _ []) = return $ Left z + go z@(Zipped bs (a : as)) = do + res <- f a x + case res of + GT -> go $ Zipped (a : bs) as + EQ -> Right <$> goEq (Unzipped bs [a] as) + LT -> return $ Left z + goEq z@(Unzipped _ _ []) = return z + goEq z@(Unzipped bs cs (a : as)) = do + res <- f a x + case res of + GT -> goEq $ Unzipped (a : bs) cs as + EQ -> goEq $ Unzipped bs (a : cs) as + LT -> return z zipperMatch :: Unzipped Match -> TxRecord -> EitherErr (Zipped Match, MatchRes RawTx) zipperMatch (Unzipped bs cs as) x = go [] cs @@ -168,16 +172,18 @@ matchDates ms = go ([], [], initZipper ms) , reverse unmatched , recoverZipper z ) - go (matched, unmatched, z) (r : rs) = case zipperSlice findDate r z of - 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 + go (matched, unmatched, z) (r : rs) = do + sliced <- zipperSlice findDate r z + case sliced of + 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 (Right EQ) (`compareDate` trDate r) $ mDate m matchNonDates :: [Match] -> [TxRecord] -> EitherErr ([RawTx], [TxRecord], [Match]) matchNonDates ms = go ([], [], initZipper ms) diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 9b9dc0d..e786552 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -508,10 +508,15 @@ data MatchRes a = MatchPass a | MatchFail | MatchSkip data BalanceType = TooFewSplits | NotOneBlank deriving (Show) +data LookupField = AccountField | CurrencyField | OtherField deriving (Show) + +-- data ConversionSubError = Malformed | deriving (Show) + data InsertError = RegexError T.Text + | YearError Natural | ConversionError T.Text - | LookupError T.Text + | LookupError LookupField T.Text | BalanceError BalanceType CurID [RawSplit] | StatementError [TxRecord] [Match] deriving (Show) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 44a1e98..17467c4 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -11,7 +11,6 @@ import RIO import qualified RIO.List as L import qualified RIO.Map as M import qualified RIO.Text as T -import qualified RIO.Text.Partial as TP import RIO.Time import Text.Regex.TDFA @@ -20,46 +19,52 @@ 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 -> (Integer, Int, Int) -gregTup g@Gregorian {..} - | gYear > 99 = error $ show g ++ ": year must only be two digits" +gregTup :: Gregorian -> EitherErr (Integer, Int, Int) +gregTup Gregorian {..} + | gYear > 99 = Left $ YearError gYear | otherwise = - ( fromIntegral gYear + 2000 - , fromIntegral gMonth - , fromIntegral gDay - ) + return + ( fromIntegral gYear + 2000 + , fromIntegral gMonth + , fromIntegral gDay + ) -gregMTup :: GregorianM -> (Integer, Int) -gregMTup g@GregorianM {..} - | gmYear > 99 = error $ show g ++ ": year must only be two digits" +gregMTup :: GregorianM -> EitherErr (Integer, Int) +gregMTup GregorianM {..} + | gmYear > 99 = Left $ YearError gmYear | otherwise = - ( fromIntegral gmYear + 2000 - , fromIntegral gmMonth - ) + return + ( fromIntegral gmYear + 2000 + , fromIntegral gmMonth + ) data MDY_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int -fromMatchYMD :: MatchYMD -> MDY_ +fromMatchYMD :: MatchYMD -> EitherErr MDY_ fromMatchYMD m = case m of Y y - | y > 99 -> error $ show m ++ ": year must only be two digits" - | otherwise -> Y_ $ fromIntegral y + 2000 - YM g -> uncurry YM_ $ gregMTup g - YMD g -> uncurry3 YMD_ $ gregTup g + | y > 99 -> Left $ YearError y + | otherwise -> Right $ Y_ $ fromIntegral y + 2000 + YM g -> uncurry YM_ <$> gregMTup g + YMD g -> uncurry3 YMD_ <$> gregTup g -compareDate :: MatchDate -> Day -> Ordering -compareDate (On md) x = case fromMatchYMD md of - Y_ y' -> compare y y' - YM_ y' m' -> compare (y, m) (y', m') - YMD_ y' m' d' -> compare (y, m, d) (y', m', d') +compareDate :: MatchDate -> Day -> EitherErr Ordering +compareDate (On md) x = do + res <- fromMatchYMD md + return $ case res of + Y_ y' -> compare y y' + YM_ y' m' -> compare (y, m) (y', m') + YMD_ y' m' d' -> compare (y, m, d) (y', m', d') where (y, m, d) = toGregorian x -compareDate (In md offset) x = case fromMatchYMD md of - Y_ y' -> compareRange y' y - YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m - YMD_ y' m' d' -> - let s = toModifiedJulianDay $ fromGregorian y' m' d' - in compareRange s $ toModifiedJulianDay x +compareDate (In md offset) x = do + res <- fromMatchYMD md + return $ case res of + Y_ y' -> compareRange y' y + YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m + YMD_ y' m' d' -> + let s = toModifiedJulianDay $ fromGregorian y' m' d' + in compareRange s $ toModifiedJulianDay x where (y, m, _) = toGregorian x compareRange start z @@ -67,8 +72,8 @@ compareDate (In md offset) x = case fromMatchYMD md of | otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ toMonth year month = (year * 12) + fromIntegral month -dateMatches :: MatchDate -> Day -> Bool -dateMatches md = (EQ ==) . compareDate md +dateMatches :: MatchDate -> Day -> EitherErr Bool +dateMatches md = fmap (EQ ==) . compareDate md valMatches :: MatchVal -> Rational -> Bool valMatches MatchVal {..} x = @@ -80,55 +85,57 @@ valMatches MatchVal {..} x = p = 10 ^ mvPrec s = signum x >= 0 -evalSplit :: TxRecord -> ExpSplit -> RawSplit -evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} = - s - { sAcnt = evalAcnt r a - , sValue = evalExp r =<< v - , sCurrency = evalCurrency r c - } +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_}) -evalAcnt :: TxRecord -> SplitAcnt -> T.Text +evalAcnt :: TxRecord -> SplitAcnt -> EitherErr T.Text evalAcnt TxRecord {trOther = o} s = case s of - ConstT p -> p - LookupT f -> read $ T.unpack $ lookupField f o - MapT (Field f m) -> let k = lookupField f o in lookupErr "account key" k m - Map2T (Field (f1, f2) m) -> - let k1 = lookupField f1 o - k2 = lookupField f2 o - in lookupErr "account key" (k1, k2) m + ConstT p -> Right p + LookupT f -> lookupErr AccountField f o + MapT (Field f m) -> do + k <- lookupErr AccountField f o + lookupErr AccountField k m + Map2T (Field (f1, f2) m) -> do + k1 <- lookupErr AccountField f1 o + k2 <- lookupErr AccountField f2 o + lookupErr AccountField (k1, k2) m -evalCurrency :: TxRecord -> SplitCur -> T.Text +evalCurrency :: TxRecord -> SplitCur -> EitherErr T.Text evalCurrency TxRecord {trOther = o} s = case s of - ConstT p -> p - LookupT f -> lookupField f o - MapT (Field f m) -> let k = lookupField f o in lookupErr "currency key" k m - Map2T (Field (f1, f2) m) -> - let k1 = lookupField f1 o - k2 = lookupField f2 o - in lookupErr "currency key" (k1, k2) m + ConstT p -> Right p + LookupT f -> lookupErr CurrencyField f o + MapT (Field f m) -> do + k <- lookupErr CurrencyField f o + lookupErr CurrencyField k m + Map2T (Field (f1, f2) m) -> do + k1 <- lookupErr CurrencyField f1 o + k2 <- lookupErr CurrencyField f2 o + lookupErr CurrencyField (k1, k2) m errorT :: T.Text -> a errorT = error . T.unpack -lookupField :: (Ord k, Show k) => k -> M.Map k v -> v -lookupField = lookupErr "field" +-- lookupField :: (Ord k, Show k) => k -> M.Map k v -> v +-- lookupField = lookupErr "field" -lookupErr :: (Ord k, Show k) => T.Text -> k -> M.Map k v -> v +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 -> x - _ -> errorT $ T.concat [what, " does not exist: ", T.pack $ show k] + Just x -> Right x + _ -> Left $ LookupError what $ showT k matches :: Match -> TxRecord -> EitherErr (MatchRes RawTx) matches Match {..} r@TxRecord {..} = do - let date = checkMaybe (`dateMatches` trDate) mDate + 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 - return $ - if date && val && desc && other - then maybe MatchSkip (MatchPass . eval) mTx - else MatchFail + if date && val && desc && other + then maybe (Right MatchSkip) (fmap MatchPass . eval) mTx + else Right MatchFail where eval (ToTx cur a ss) = toTx cur a ss r @@ -137,32 +144,35 @@ matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re fieldMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr Bool fieldMatches dict m = case m of - Val (Field n mv) -> valMatches mv <$> (readRationalMsg =<< lookup_ n) + Val (Field n mv) -> valMatches mv <$> (readRational =<< 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 $ LookupError n + Nothing -> Left $ LookupError OtherField n checkMaybe :: (a -> Bool) -> Maybe a -> Bool checkMaybe = maybe True -toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> RawTx -toTx sc sa toSplits r@TxRecord {..} = - Tx - { txTags = [] - , txDate = trDate - , txDescr = trDesc - , txSplits = fromSplit : fmap (evalSplit r) toSplits - } - where - fromSplit = - Split - { sAcnt = evalAcnt r sa - , sCurrency = evalCurrency r sc - , sValue = Just trAmount - , sComment = "" - } +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 = "" + } + return $ + Tx + { txTags = [] + , txDate = trDate + , txDescr = trDesc + , txSplits = fromSplit : ss_ + } parseRational :: MonadFail m => T.Text -> T.Text -> m Rational parseRational pat s = case ms of @@ -197,34 +207,35 @@ 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 +-- readRationalMsg :: T.Text -> EitherErr Rational +-- readRationalMsg t = maybe (Left $ ConversionError t) Right $ readRational t --- TODO don't use a partial function -readRational :: MonadFail m => T.Text -> m Rational -readRational s = case TP.splitOn "." s of - [x] -> return $ fromInteger $ readT x - [x, y] -> - let x' = readT x - y' = readT y - p = 10 ^ T.length y - k = if x' >= 0 then 1 else -1 - in if y' > p - then fail "not enough precision to parse" - else return $ fromInteger x' + k * y' % p - _ -> fail $ T.unpack $ T.append "malformed decimal: " s +readRational :: T.Text -> EitherErr Rational +readRational s = case T.split (== '.') s of + [x] -> maybe err (return . fromInteger) $ readT x + [x, y] -> case (readT x, readT y) of + (Just x', Just y') -> + let p = 10 ^ T.length y + k = if x' >= 0 then 1 else -1 + in return $ fromInteger x' + k * y' % p + _ -> err + _ -> err where - readT = read . T.unpack + readT = readMaybe . T.unpack + err = Left $ ConversionError s -- TODO smells like a lens mapTxSplits :: (a -> b) -> Tx a -> Tx b mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss} -boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds -boundsFromGregorian = bimap fromGregorian' fromGregorian' +boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErr Bounds +boundsFromGregorian (a, b) = do + a_ <- fromGregorian' a + b_ <- fromGregorian' b + return (a_, b_) -fromGregorian' :: Gregorian -> Day -fromGregorian' = uncurry3 fromGregorian . gregTup +fromGregorian' :: Gregorian -> EitherErr Day +fromGregorian' = fmap (uncurry3 fromGregorian) . gregTup inBounds :: Bounds -> Day -> Bool inBounds (d0, d1) x = d0 <= x && x <= d1 @@ -232,9 +243,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 -> MaybeBounds -intervalMaybeBounds Interval {intStart = s, intEnd = e} = - (fromGregorian' <$> s, fromGregorian' <$> e) +intervalMaybeBounds :: Interval -> EitherErr MaybeBounds +intervalMaybeBounds Interval {intStart = s, intEnd = e} = do + s_ <- mapM fromGregorian' s + e_ <- mapM fromGregorian' e + return (s_, e_) resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds resolveBounds (s, e) = do @@ -264,11 +277,11 @@ lpad c n s = replicate (n - length s) c ++ s rpad :: a -> Int -> [a] -> [a] rpad c n s = s ++ replicate (n - length s) c -evalExp :: TxRecord -> SplitNum -> Maybe Rational +evalExp :: TxRecord -> SplitNum -> EitherErr Rational evalExp r s = case s of - (LookupN t) -> readRational =<< M.lookup t (trOther r) - (ConstN c) -> Just $ dec2Rat c - AmountN -> Just $ trAmount r + (LookupN t) -> readRational =<< lookupErr OtherField t (trOther r) + (ConstN c) -> Right $ dec2Rat c + AmountN -> Right $ trAmount r dec2Rat :: Decimal -> Rational dec2Rat D {..} = @@ -282,10 +295,11 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) showError :: InsertError -> [T.Text] showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms) showError other = (: []) $ case other of + (YearError y) -> T.append "Year must be two digits: " $ showT y (RegexError re) -> T.append "could not make regex from pattern: " re (ConversionError x) -> T.append "Could not convert to rational number: " x - (LookupError f) -> T.append "Could not find field: " f - -- TODO these balance errors are useless, need more info on the tx being balanced + -- TODO use the field indicator + (LookupError _ f) -> T.append "Could not find field: " f (BalanceError t cur rss) -> T.concat [ msg