From 47480d27c4cdd33dae536b4068128a6348ffa6f0 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 5 Jan 2023 22:23:22 -0500 Subject: [PATCH] ENH generalize IO monads --- app/Main.hs | 16 +-- lib/Internal/Config.hs | 6 +- lib/Internal/Database/Ops.hs | 38 ++++--- lib/Internal/Insert.hs | 46 ++++---- lib/Internal/Statement.hs | 207 ++++++++++++++++++----------------- lib/Internal/Utils.hs | 2 +- 6 files changed, 160 insertions(+), 155 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c0844be..1e5c4ad 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -107,15 +107,15 @@ parse (Options c DumpAccountKeys) = runDumpAccountKeys c parse (Options c DumpCurrencies) = runDumpCurrencies c parse (Options c Sync) = runSync c -runDumpCurrencies :: FilePath -> IO () +runDumpCurrencies :: MonadUnliftIO m => FilePath -> m () runDumpCurrencies c = do cs <- currencies <$> readConfig c - putStrLn $ T.unpack $ T.unlines $ fmap fmt cs + liftIO $ putStrLn $ T.unpack $ T.unlines $ fmap fmt cs where fmt Currency {curSymbol = s, curFullname = f} = T.concat [s, ": ", f] -runDumpAccounts :: FilePath -> IO () +runDumpAccounts :: MonadUnliftIO m => FilePath -> m () runDumpAccounts c = do ar <- accounts <$> readConfig c mapM_ (\(h, f) -> printTree h $ f ar) ps @@ -128,7 +128,7 @@ runDumpAccounts c = do , ("Liabilities", arLiabilities) ] printTree h ts = do - putStrLn h + liftIO $ putStrLn h mapM (go 1) ts go i (Placeholder d n cs) = do printAcnt i d n @@ -136,9 +136,9 @@ runDumpAccounts c = do go i (Account d n) = printAcnt i d n printAcnt i d n = do let ind = T.replicate (i * 2) " " - putStrLn $ T.unpack $ T.concat [ind, n, ": ", d] + liftIO $ putStrLn $ T.unpack $ T.concat [ind, n, ": ", d] -runDumpAccountKeys :: FilePath -> IO () +runDumpAccountKeys :: MonadUnliftIO m => FilePath -> m () runDumpAccountKeys c = do ar <- accounts <$> readConfig c let ks = @@ -149,11 +149,11 @@ runDumpAccountKeys c = do mapM_ (uncurry printPair) ks where printPair i p = do - putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i] + liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i] t3 (_, _, x) = x double x = (x, x) -runSync :: FilePath -> IO () +runSync :: MonadUnliftIO m => FilePath -> m () runSync c = do config <- readConfig c migrate_ (sqlConfig config) $ do diff --git a/lib/Internal/Config.hs b/lib/Internal/Config.hs index 99bccf9..30a07c7 100644 --- a/lib/Internal/Config.hs +++ b/lib/Internal/Config.hs @@ -8,10 +8,10 @@ where -- import Data.Yaml import Dhall hiding (record) import Internal.Types +import RIO -readConfig :: FilePath -> IO Config -readConfig confpath = do - unfix <$> inputFile auto confpath +readConfig :: MonadUnliftIO m => FilePath -> m Config +readConfig confpath = liftIO $ unfix <$> inputFile auto confpath -- readYaml :: FromJSON a => FilePath -> IO a -- readYaml p = do diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index ad42639..b0623b4 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -33,7 +33,11 @@ import qualified RIO.List as L import qualified RIO.Map as M import qualified RIO.Text as T -migrate_ :: SqlConfig -> SqlPersistT (ResourceT (NoLoggingT IO)) () -> IO () +migrate_ + :: MonadUnliftIO m + => SqlConfig + -> SqlPersistT (ResourceT (NoLoggingT m)) () + -> m () migrate_ c more = runNoLoggingT $ runResourceT $ @@ -45,21 +49,21 @@ migrate_ c more = more ) -openConnection :: SqlConfig -> LogFunc -> IO SqlBackend +openConnection :: MonadUnliftIO m => SqlConfig -> LogFunc -> m SqlBackend openConnection c logfn = case c of - Sqlite p -> do + Sqlite p -> liftIO $ do conn <- open p wrapConnection conn logfn Postgres -> error "postgres not implemented" -nukeTables :: MonadIO m => SqlPersistT m () +nukeTables :: MonadUnliftIO m => SqlPersistT m () nukeTables = do deleteWhere ([] :: [Filter CommitR]) deleteWhere ([] :: [Filter CurrencyR]) deleteWhere ([] :: [Filter AccountR]) deleteWhere ([] :: [Filter TransactionR]) -showBalances :: MonadIO m => SqlPersistT m () +showBalances :: MonadUnliftIO m => SqlPersistT m () showBalances = do xs <- select $ do (accounts :& splits :& txs) <- @@ -121,47 +125,47 @@ setDiff as bs = (as \\ bs, bs \\ as) -- | f a b = Just bs -- | otherwise = inB a bs -getDBHashes :: MonadIO m => SqlPersistT m [Int] +getDBHashes :: MonadUnliftIO m => SqlPersistT m [Int] getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl -nukeDBHash :: MonadIO m => Int -> SqlPersistT m () +nukeDBHash :: MonadUnliftIO m => Int -> SqlPersistT m () nukeDBHash h = delete $ do c <- from table where_ (c ^. CommitRHash ==. val h) -nukeDBHashes :: MonadIO m => [Int] -> SqlPersistT m () +nukeDBHashes :: MonadUnliftIO m => [Int] -> SqlPersistT m () nukeDBHashes = mapM_ nukeDBHash -getConfigHashes :: MonadIO m => Config -> SqlPersistT m ([Int], [Int]) +getConfigHashes :: MonadUnliftIO m => Config -> SqlPersistT m ([Int], [Int]) getConfigHashes c = do let ch = hashConfig c dh <- getDBHashes return $ setDiff dh ch -updateHashes :: MonadIO m => Config -> SqlPersistT m [Int] +updateHashes :: MonadUnliftIO m => Config -> SqlPersistT m [Int] updateHashes c = do (del, new) <- getConfigHashes c nukeDBHashes del return new -dumpTbl :: (PersistEntity r, MonadIO m) => SqlPersistT m [Entity r] +dumpTbl :: (PersistEntity r, MonadUnliftIO m) => SqlPersistT m [Entity r] dumpTbl = select $ from table -deleteAccount :: MonadIO m => Entity AccountR -> SqlPersistT m () +deleteAccount :: MonadUnliftIO m => Entity AccountR -> SqlPersistT m () deleteAccount e = delete $ do c <- from $ table @AccountR where_ (c ^. AccountRId ==. val k) where k = entityKey e -deleteCurrency :: MonadIO m => Entity CurrencyR -> SqlPersistT m () +deleteCurrency :: MonadUnliftIO m => Entity CurrencyR -> SqlPersistT m () deleteCurrency e = delete $ do c <- from $ table @CurrencyR where_ (c ^. CurrencyRId ==. val k) where k = entityKey e -updateAccounts :: MonadIO m => AccountRoot -> SqlPersistT m AccountMap +updateAccounts :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap updateAccounts ar = do let (acnts, paths, acntMap) = indexAcntRoot ar acnts' <- dumpTbl @@ -174,12 +178,12 @@ updateAccounts ar = do return acntMap insertFull - :: (MonadIO m, PersistStoreWrite b, PersistRecordBackend r b) + :: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b) => Entity r -> ReaderT b m () insertFull (Entity k v) = insertKey k v -updateCurrencies :: MonadIO m => [Currency] -> SqlPersistT m CurrencyMap +updateCurrencies :: MonadUnliftIO m => [Currency] -> SqlPersistT m CurrencyMap updateCurrencies cs = do let curs = fmap currency2Record cs curs' <- select $ from $ table @CurrencyR @@ -298,7 +302,7 @@ indexAcntRoot r = where (ars, aprs, ms) = unzip3 $ uncurry tree2Records <$> flattenAcntRoot r -getDBState :: MonadIO m => Config -> SqlPersistT m (FilePath -> DBState) +getDBState :: MonadUnliftIO m => Config -> SqlPersistT m (FilePath -> DBState) getDBState c = do am <- updateAccounts $ accounts c cm <- updateCurrencies $ currencies c diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index c5628a9..f4f73b5 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -20,7 +20,7 @@ import qualified RIO.Map as M import qualified RIO.Text as T import RIO.Time -lookupKey :: (Ord k, Show k, MonadIO m) => M.Map k v -> k -> m (Maybe v) +lookupKey :: (Ord k, Show k, MonadUnliftIO m) => M.Map k v -> k -> m (Maybe v) lookupKey m k = do let v = M.lookup k m when (isNothing v) $ @@ -29,18 +29,18 @@ lookupKey m k = do "key does not exist: " ++ show k return v -lookupAccount :: MonadIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign)) +lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign)) lookupAccount p = do m <- asks kmAccount lookupKey m p -lookupAccountKey :: MonadIO m => AcntID -> MappingT m (Maybe (Key AccountR)) +lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR)) lookupAccountKey = fmap (fmap fst) . lookupAccount -lookupAccountSign :: MonadIO m => AcntID -> MappingT m (Maybe AcntSign) +lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (Maybe AcntSign) lookupAccountSign = fmap (fmap snd) . lookupAccount -lookupCurrency :: MonadIO m => T.Text -> MappingT m (Maybe (Key CurrencyR)) +lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (Maybe (Key CurrencyR)) lookupCurrency c = do m <- asks kmCurrency lookupKey m c @@ -121,7 +121,7 @@ mdyPatternMatches check x p = case p of -------------------------------------------------------------------------------- -- budget -insertBudget :: MonadIO m => Budget -> MappingT m () +insertBudget :: MonadUnliftIO m => Budget -> MappingT m () insertBudget Budget {income = is, expenses = es} = do mapM_ insertIncome is mapM_ insertExpense es @@ -129,7 +129,7 @@ insertBudget Budget {income = is, expenses = es} = do -- TODO this hashes twice (not that it really matters) whenHash :: Hashable a - => MonadIO m + => MonadUnliftIO m => ConfigType -> a -> (Key CommitR -> MappingT m ()) @@ -140,7 +140,7 @@ whenHash t o f = do when (h `elem` hs) $ do f =<< lift (insert $ CommitR h t) -insertIncome :: MonadIO m => Income -> MappingT m () +insertIncome :: MonadUnliftIO m => Income -> MappingT m () insertIncome i@Income { incCurrency = cur @@ -204,7 +204,7 @@ mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b mapAmts f a@Allocation {alloAmts = xs} = a {alloAmts = f xs} allocationToTx - :: MonadIO m + :: MonadUnliftIO m => AcntID -> Day -> BalAllocation @@ -220,12 +220,12 @@ allocationToTx } = fmap (,b) <$> mapM (transferToTx day from to cur) as -taxToTx :: MonadIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx +taxToTx :: MonadUnliftIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx taxToTx from day cur Tax {taxAcnt = to, taxValue = v} = txPair day from to cur (dec2Rat v) "" transferToTx - :: MonadIO m + :: MonadUnliftIO m => Day -> AcntID -> AcntID @@ -235,7 +235,7 @@ transferToTx transferToTx day from to cur Amount {amtValue = v, amtDesc = d} = txPair day from to cur v d -insertExpense :: MonadIO m => Expense -> MappingT m () +insertExpense :: MonadUnliftIO m => Expense -> MappingT m () insertExpense e@Expense { expFrom = from @@ -249,7 +249,7 @@ insertExpense lift $ mapM_ (insertTxBucket (Just buc) c) ts timeAmountToTx - :: MonadIO m + :: MonadUnliftIO m => AcntID -> AcntID -> T.Text @@ -275,14 +275,14 @@ timeAmountToTx -------------------------------------------------------------------------------- -- statements -insertStatements :: MonadIO m => Config -> MappingT m () +insertStatements :: MonadUnliftIO m => Config -> MappingT m () insertStatements = mapM_ insertStatement . statements -insertStatement :: MonadIO m => Statement -> MappingT m () +insertStatement :: MonadUnliftIO m => Statement -> MappingT m () insertStatement (StmtManual m) = insertManual m insertStatement (StmtImport i) = insertImport i -insertManual :: MonadIO m => Manual -> MappingT m () +insertManual :: MonadUnliftIO m => Manual -> MappingT m () insertManual m@Manual { manualDate = dp @@ -299,7 +299,7 @@ insertManual where tx day = txPair day from to u (dec2Rat v) e -insertImport :: MonadIO m => Import -> MappingT m () +insertImport :: MonadUnliftIO m => Import -> MappingT m () insertImport i = whenHash CTImport i $ \c -> do bounds <- asks kmStatementInterval bs <- readImport i @@ -312,7 +312,7 @@ insertImport i = whenHash CTImport i $ \c -> do -- low-level transaction stuff txPair - :: MonadIO m + :: MonadUnliftIO m => Day -> AcntID -> AcntID @@ -331,12 +331,12 @@ txPair day from to cur val desc = resolveTx tx , txSplits = [split from (-val), split to val] } -resolveTx :: MonadIO m => BalTx -> MappingT m KeyTx +resolveTx :: MonadUnliftIO m => BalTx -> MappingT m KeyTx resolveTx t@Tx {txSplits = ss} = do rs <- catMaybes <$> mapM resolveSplit ss return $ t {txSplits = rs} -resolveSplit :: MonadIO m => BalSplit -> MappingT m (Maybe KeySplit) +resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (Maybe KeySplit) resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do aid <- lookupAccountKey p cid <- lookupCurrency c @@ -353,14 +353,14 @@ resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do } _ -> Nothing -insertTxBucket :: MonadIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m () +insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m () insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do k <- insert $ TransactionR c d e (fmap (T.pack . show) b) mapM_ (insertSplit k) ss -insertTx :: MonadIO m => Key CommitR -> KeyTx -> SqlPersistT m () +insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m () insertTx = insertTxBucket Nothing -insertSplit :: MonadIO m => Key TransactionR -> KeySplit -> SqlPersistT m () +insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m () insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do insert_ $ SplitR t cid aid c v diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index 556265e..4b690bf 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -3,9 +3,10 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -module Internal.Statement ( - readImport, -) where +module Internal.Statement + ( readImport + ) +where import Data.Csv import Internal.Database.Model @@ -22,84 +23,84 @@ import qualified RIO.Vector as V -- TODO this probably won't scale well (pipes?) -readImport :: MonadIO m => Import -> MappingT m [BalTx] +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 + 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_ :: - MonadIO m => - Natural -> - Word -> - TxOpts -> - FilePath -> - MappingT m [TxRecord] +readImport_ + :: MonadUnliftIO m + => Natural + -> Word + -> TxOpts + -> FilePath + -> MappingT m [TxRecord] readImport_ n delim tns p = do - dir <- asks kmConfigDir - bs <- liftIO $ BL.readFile $ dir p - case decodeByNameWithP (parseTxRecord tns) opts $ skip bs of - Left m -> liftIO $ putStrLn m >> return [] - Right (_, v) -> return $ catMaybes $ V.toList v + dir <- asks kmConfigDir + bs <- liftIO $ BL.readFile $ dir p + case decodeByNameWithP (parseTxRecord tns) opts $ skip bs of + Left m -> liftIO $ putStrLn m >> return [] + Right (_, v) -> return $ catMaybes $ V.toList v where - opts = defaultDecodeOptions{decDelimiter = fromIntegral delim} + opts = defaultDecodeOptions {decDelimiter = fromIntegral delim} skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10 -- TODO handle this better, this maybe thing is a hack to skip lines with -- blank dates but will likely want to make this more flexible parseTxRecord :: TxOpts -> NamedRecord -> Parser (Maybe TxRecord) -parseTxRecord TxOpts{..} r = do - d <- r .: T.encodeUtf8 toDate - if d == "" - then return Nothing - else do - a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount - e <- r .: T.encodeUtf8 toDesc - os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther - d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d - return $ Just $ TxRecord d' a e os +parseTxRecord TxOpts {..} r = do + d <- r .: T.encodeUtf8 toDate + if d == "" + then return Nothing + else do + a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount + e <- r .: T.encodeUtf8 toDesc + os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther + 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 - ) + ( 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 + partitionEithers $ + fmap Just . balanceTx <$> catMaybes matched bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched matchPriorities :: [Match] -> [MatchGroup] matchPriorities = - fmap matchToGroup - . L.groupBy (\a b -> mPriority a == mPriority b) - . L.sortOn (Down . mPriority) + fmap matchToGroup + . L.groupBy (\a b -> mPriority a == mPriority b) + . L.sortOn (Down . mPriority) matchToGroup :: [Match] -> MatchGroup matchToGroup ms = - uncurry MatchGroup $ - first (L.sortOn mDate) $ - L.partition (isJust . mDate) ms + uncurry MatchGroup $ + first (L.sortOn mDate) $ + L.partition (isJust . mDate) ms -- TDOO could use a better struct to flatten the maybe date subtype data MatchGroup = MatchGroup - { mgDate :: [Match] - , mgNoDate :: [Match] - } - deriving (Show) + { mgDate :: [Match] + , mgNoDate :: [Match] + } + deriving (Show) data Zipped a = Zipped ![a] ![a] @@ -119,37 +120,37 @@ 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 + 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 + GT -> goEq $ Unzipped (a : bs) cs as + EQ -> goEq $ Unzipped bs (a : cs) as + LT -> z zipperMatch :: Unzipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe 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) + Nothing -> go (m : prev) ms + res@(Just _) -> + let ps = reverse prev + ms' = maybe ms (: ms) (matchDec m) + in (Zipped bs $ ps ++ ms' ++ as, res) zipperMatch' :: Zipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe 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) + Nothing -> go (Zipped (a : bs) as) + res -> (Zipped (maybe bs (: bs) $ matchDec a) as, res) go z' = (z', Nothing) matchDec :: Match -> Maybe Match -matchDec m@Match{mTimes = t} = - if t' == Just 0 then Nothing else Just $ m{mTimes = t'} +matchDec m@Match {mTimes = t} = + if t' == Just 0 then Nothing else Just $ m {mTimes = t'} where t' = fmap pred t @@ -157,15 +158,15 @@ matchAll :: [MatchGroup] -> [TxRecord] -> ([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 + (_, []) -> (matched, [], unused) + ([], _) -> (matched, rs, unused) + (g : gs', _) -> + let (ts, unmatched, us) = matchGroup g rs + in 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) +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 @@ -175,13 +176,13 @@ matchDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = (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 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 findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m matchNonDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) @@ -189,32 +190,32 @@ 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) - in go (m, u, resetZipper z') rs + let (z', res) = zipperMatch' z r + (m, u) = case res of + Just x -> (x : matched, unmatched) + Nothing -> (matched, r : unmatched) + in go (m, u, resetZipper z') rs balanceTx :: RawTx -> Either T.Text BalTx -balanceTx t@Tx{txSplits = ss} = do - bs <- balanceSplits ss - return $ t{txSplits = bs} +balanceTx t@Tx {txSplits = ss} = do + bs <- balanceSplits ss + return $ t {txSplits = bs} balanceSplits :: [RawSplit] -> Either T.Text [BalSplit] balanceSplits ss = - fmap concat - <$> mapM (uncurry bal) - $ groupByKey - $ fmap (\s -> (sCurrency s, s)) ss + fmap concat + <$> mapM (uncurry bal) + $ groupByKey + $ fmap (\s -> (sCurrency s, s)) ss where - hasValue s@(Split{sValue = Just v}) = Right s{sValue = v} + hasValue s@(Split {sValue = Just v}) = Right s {sValue = v} hasValue s = Left s bal cur rss - | length rss < 2 = Left $ T.append "Need at least two splits to balance: " cur - | otherwise = case partitionEithers $ fmap hasValue rss of - ([noVal], val) -> Right $ noVal{sValue = foldr (\s x -> x - sValue s) 0 val} : val - ([], val) -> Right val - _ -> Left $ T.append "Exactly one split must be blank: " cur + | length rss < 2 = Left $ T.append "Need at least two splits to balance: " cur + | otherwise = case partitionEithers $ fmap hasValue rss of + ([noVal], val) -> Right $ noVal {sValue = foldr (\s x -> x - sValue s) 0 val} : val + ([], val) -> Right val + _ -> Left $ T.append "Exactly one split must be blank: " cur groupByKey :: Ord k => [(k, v)] -> [(k, [v])] groupByKey = M.toList . M.fromListWith (++) . fmap (second (: [])) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index b9a5b44..395ebf7 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -227,7 +227,7 @@ intervalMaybeBounds :: Interval -> MaybeBounds intervalMaybeBounds Interval {intStart = s, intEnd = e} = (fromGregorian' <$> s, fromGregorian' <$> e) -resolveBounds :: MaybeBounds -> IO Bounds +resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds resolveBounds (s, e) = do s' <- maybe getDay return s e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e