From 20cc4db9867377619a9ad7e8b4f82ab15031f97c Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 5 Jan 2023 22:16:06 -0500 Subject: [PATCH] ENH use rio modules everywhere and use recommended flags --- app/Main.hs | 155 ++++++----- budget.cabal | 24 +- lib/Internal/Config.hs | 81 +----- lib/Internal/Database/Model.hs | 61 ++--- lib/Internal/Database/Ops.hs | 237 ++++++++-------- lib/Internal/Insert.hs | 378 ++++++++++++++----------- lib/Internal/Statement.hs | 262 +++++++++--------- lib/Internal/Types.hs | 488 +++++++++++++++++---------------- lib/Internal/Utils.hs | 182 ++++++------ package.yaml | 33 +-- 10 files changed, 971 insertions(+), 930 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 8a80d47..c0844be 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,106 +2,117 @@ module Main (main) where -import qualified Data.Text as T - -import Internal.Config -import Internal.Database.Ops -import Internal.Insert -import Internal.Types -import Internal.Utils - -import Control.Monad.Trans.Reader - -import Options.Applicative - -import System.FilePath +import Internal.Config +import Internal.Database.Ops +import Internal.Insert +import Internal.Types +import Internal.Utils +import Options.Applicative +import RIO +import RIO.FilePath +import qualified RIO.Text as T main :: IO () main = parse =<< execParser o where - o = info (options <**> helper) - ( fullDesc - <> progDesc "Pwn your budget" - <> header "pwncash - your budget, your life" - ) + o = + info + (options <**> helper) + ( fullDesc + <> progDesc "Pwn your budget" + <> header "pwncash - your budget, your life" + ) data Options = Options FilePath Mode -data Mode = Reset +data Mode + = Reset | DumpCurrencies | DumpAccounts | DumpAccountKeys | Sync configFile :: Parser FilePath -configFile = strOption - ( long "config" - <> short 'c' - <> metavar "CONFIG" - <> value "main.dhall" - <> help "config file to use" - ) +configFile = + strOption + ( long "config" + <> short 'c' + <> metavar "CONFIG" + <> value "main.dhall" + <> help "config file to use" + ) options :: Parser Options -options = getConf reset - <|> getConf dumpCurrencies - <|> getConf dumpAccounts - <|> getConf dumpAccountKeys - <|> getConf sync +options = + getConf reset + <|> getConf dumpCurrencies + <|> getConf dumpAccounts + <|> getConf dumpAccountKeys + <|> getConf sync where getConf m = Options <$> configFile <*> m reset :: Parser Mode -reset = flag' Reset - ( long "reset" - <> short 'R' - <> help "Reset the database" - ) +reset = + flag' + Reset + ( long "reset" + <> short 'R' + <> help "Reset the database" + ) dumpCurrencies :: Parser Mode -dumpCurrencies = flag' DumpCurrencies - ( long "currencies" - <> short 'C' - <> help "Dump all currencies in the configuration" - ) +dumpCurrencies = + flag' + DumpCurrencies + ( long "currencies" + <> short 'C' + <> help "Dump all currencies in the configuration" + ) dumpAccounts :: Parser Mode -dumpAccounts = flag' DumpAccounts - ( long "accounts" - <> short 'A' - <> help "Dump all accounts in the configuration" - ) +dumpAccounts = + flag' + DumpAccounts + ( long "accounts" + <> short 'A' + <> help "Dump all accounts in the configuration" + ) -- TODO 'alias' is a better name for these dumpAccountKeys :: Parser Mode -dumpAccountKeys = flag' DumpAccountKeys - ( long "account_keys" - <> short 'K' - <> help "Dump all account keys/aliases" - ) +dumpAccountKeys = + flag' + DumpAccountKeys + ( long "account_keys" + <> short 'K' + <> help "Dump all account keys/aliases" + ) sync :: Parser Mode -sync = flag' Sync - ( long "sync" - <> short 'S' - <> help "Sync config to database" - ) +sync = + flag' + Sync + ( long "sync" + <> short 'S' + <> help "Sync config to database" + ) parse :: Options -> IO () -parse (Options c Reset) = do +parse (Options c Reset) = do config <- readConfig c migrate_ (sqlConfig config) nukeTables -parse (Options c DumpAccounts) = runDumpAccounts c +parse (Options c DumpAccounts) = runDumpAccounts c parse (Options c DumpAccountKeys) = runDumpAccountKeys c -parse (Options c DumpCurrencies) = runDumpCurrencies c -parse (Options c Sync) = runSync c +parse (Options c DumpCurrencies) = runDumpCurrencies c +parse (Options c Sync) = runSync c runDumpCurrencies :: FilePath -> IO () runDumpCurrencies c = do cs <- currencies <$> readConfig c putStrLn $ T.unpack $ T.unlines $ fmap fmt cs where - fmt Currency { curSymbol = s, curFullname = f } = + fmt Currency {curSymbol = s, curFullname = f} = T.concat [s, ": ", f] runDumpAccounts :: FilePath -> IO () @@ -109,12 +120,13 @@ runDumpAccounts c = do ar <- accounts <$> readConfig c mapM_ (\(h, f) -> printTree h $ f ar) ps where - ps = [ ("Assets", arAssets) - , ("Equity", arEquity) - , ("Expenses", arExpenses) - , ("Income", arIncome) - , ("Liabilities", arLiabilities) - ] + ps = + [ ("Assets", arAssets) + , ("Equity", arEquity) + , ("Expenses", arExpenses) + , ("Income", arIncome) + , ("Liabilities", arLiabilities) + ] printTree h ts = do putStrLn h mapM (go 1) ts @@ -129,10 +141,11 @@ runDumpAccounts c = do runDumpAccountKeys :: FilePath -> IO () runDumpAccountKeys c = do ar <- accounts <$> readConfig c - let ks = paths2IDs - $ fmap (double . fst) - $ concatMap (t3 . uncurry tree2Records) - $ flattenAcntRoot ar + let ks = + paths2IDs $ + fmap (double . fst) $ + concatMap (t3 . uncurry tree2Records) $ + flattenAcntRoot ar mapM_ (uncurry printPair) ks where printPair i p = do diff --git a/budget.cabal b/budget.cabal index 5cf2899..90ea7b0 100644 --- a/budget.cabal +++ b/budget.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack @@ -26,20 +26,19 @@ source-repository head library exposed-modules: Internal.Config - Internal.Types - Internal.Utils - Internal.Database.Ops Internal.Database.Model + Internal.Database.Ops Internal.Insert Internal.Statement + Internal.Types + Internal.Utils other-modules: Paths_budget hs-source-dirs: lib/ - ghc-options: -Wall -Werror -threaded -Wpartial-fields + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 build-depends: base >=4.12 && <10 - , bytestring , cassava , conduit >=1.3.4.2 , containers >=0.6.4.1 @@ -56,13 +55,10 @@ library , persistent-sqlite >=2.13.1.0 , recursion-schemes , regex-tdfa + , rio >=0.1.21.0 , template-haskell , text >=1.2.5.0 , time >=1.9.3 - , transformers - , utf8-string - , vector - , yaml default-language: Haskell2010 executable pwncash @@ -71,11 +67,10 @@ executable pwncash Paths_budget hs-source-dirs: app - ghc-options: -Wall -Werror -threaded -Wpartial-fields -O2 + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded build-depends: base >=4.12 && <10 , budget - , bytestring , cassava , conduit >=1.3.4.2 , containers >=0.6.4.1 @@ -92,11 +87,8 @@ executable pwncash , persistent-sqlite >=2.13.1.0 , recursion-schemes , regex-tdfa + , rio >=0.1.21.0 , template-haskell , text >=1.2.5.0 , time >=1.9.3 - , transformers - , utf8-string - , vector - , yaml default-language: Haskell2010 diff --git a/lib/Internal/Config.hs b/lib/Internal/Config.hs index d472ba7..99bccf9 100644 --- a/lib/Internal/Config.hs +++ b/lib/Internal/Config.hs @@ -1,76 +1,21 @@ module Internal.Config ( readConfig - , readYaml - ) where + -- , readYaml + ) +where -import Control.Exception --- import Control.Lens - --- import Data.Maybe --- import qualified Data.Text as T --- import Data.Typeable --- import Data.Void -import Data.Yaml - -import Dhall hiding (record) --- import qualified Dhall.Core as DC --- import qualified Dhall.Map as DM --- import Dhall.Src - -import Internal.Types +-- import Control.Exception +-- import Data.Yaml +import Dhall hiding (record) +import Internal.Types readConfig :: FilePath -> IO Config readConfig confpath = do - -- let subs = DM.fromList typeSubs - -- let settings = over substitutions (DM.union subs) defaultEvaluateSettings - -- unfix <$> inputFileWithSettings settings auto confpath unfix <$> inputFile auto confpath --- typeSubs :: [(T.Text, DC.Expr Src Void)] --- typeSubs = firstOrder ++ higherOrder --- where --- toVar a = fmap (\n -> (T.pack $ show n, maximum $ expected a)) --- $ listToMaybe $ snd $ splitTyConApp $ typeOf a --- higherOrder = --- [ ("ExpSplit", maximum $ expected (auto :: Decoder ExpSplit)) --- , ("ExpTx", maximum $ expected (auto :: Decoder ExpTx)) --- , ("SplitCur", maximum $ expected (auto :: Decoder SplitCur)) --- , ("SplitAcnt", maximum $ expected (auto :: Decoder SplitAcnt)) --- , ("CurID", maximum $ expected (auto :: Decoder CurID)) --- , ("AcntID", maximum $ expected (auto :: Decoder AcntID)) --- ] --- firstOrder = catMaybes --- [ toVar (auto :: Decoder TimeUnit) --- , toVar (auto :: Decoder WeekdayPat) --- , toVar (auto :: Decoder MDYPat) --- , toVar (auto :: Decoder Gregorian) --- , toVar (auto :: Decoder GregorianM) --- , toVar (auto :: Decoder ModPat) --- , toVar (auto :: Decoder CronPat) --- , toVar (auto :: Decoder DatePat) --- , toVar (auto :: Decoder Income) --- , toVar (auto :: Decoder Tax) --- , toVar (auto :: Decoder Bucket) --- , toVar (auto :: Decoder TimeAmount) --- , toVar (auto :: Decoder Expense) --- , toVar (auto :: Decoder Decimal) --- , toVar (auto :: Decoder Statement) --- , toVar (auto :: Decoder Manual) --- , toVar (auto :: Decoder TxOpts) --- , toVar (auto :: Decoder ToTx) --- , toVar (auto :: Decoder Match) --- , toVar (auto :: Decoder MatchYMD) --- , toVar (auto :: Decoder MatchVal) --- , toVar (auto :: Decoder MatchDate) --- , toVar (auto :: Decoder SplitNum) --- , toVar (auto :: Decoder MatchDesc) --- , toVar (auto :: Decoder MatchOther) --- , toVar (auto :: Decoder SqlConfig) --- ] - -readYaml :: FromJSON a => FilePath -> IO a -readYaml p = do - r <- decodeFileEither p - case r of - Right a -> return a - Left e -> throw e +-- readYaml :: FromJSON a => FilePath -> IO a +-- readYaml p = do +-- r <- decodeFileEither p +-- case r of +-- Right a -> return a +-- Left e -> throw e diff --git a/lib/Internal/Database/Model.hs b/lib/Internal/Database/Model.hs index fe3946e..da7f564 100644 --- a/lib/Internal/Database/Model.hs +++ b/lib/Internal/Database/Model.hs @@ -1,34 +1,33 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Internal.Database.Model where -import Control.Monad.Trans.Reader +import Database.Esqueleto.Experimental +import Database.Persist.TH +import Internal.Types +import RIO +import qualified RIO.Map as M +import qualified RIO.Text as T +import RIO.Time -import qualified Data.Map as M -import qualified Data.Text as T -import Data.Time - -import Database.Esqueleto.Experimental -import Database.Persist.TH - -import Internal.Types - -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migrateAll"] + [persistLowerCase| CommitR sql=commits hash Int type ConfigType @@ -67,12 +66,12 @@ type AccountMap = M.Map AcntID (AccountRId, AcntSign) type CurrencyMap = M.Map CurID CurrencyRId data DBState = DBState - { kmCurrency :: !CurrencyMap - , kmAccount :: !AccountMap - , kmBudgetInterval :: !MaybeBounds + { kmCurrency :: !CurrencyMap + , kmAccount :: !AccountMap + , kmBudgetInterval :: !MaybeBounds , kmStatementInterval :: !MaybeBounds - , kmNewCommits :: ![Int] - , kmConfigDir :: FilePath + , kmNewCommits :: ![Int] + , kmConfigDir :: FilePath } type MappingT m a = ReaderT DBState (SqlPersistT m) a diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index a9d51fa..ad42639 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Internal.Database.Ops ( migrate_ @@ -14,38 +14,36 @@ module Internal.Database.Ops , tree2Records , flattenAcntRoot , paths2IDs + ) +where - ) where - -import Control.Monad.Logger -import Control.Monad.Trans.Reader - -import Conduit - -import Data.Bifunctor -import Data.Either -import Data.Hashable -import Data.List ((\\)) -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Text as T - -import Database.Esqueleto.Experimental -import Database.Persist.Sql hiding (delete, (==.), (||.)) -import Database.Persist.Sqlite hiding (delete, (==.), (||.)) -import Database.Sqlite hiding (Config) - -import Internal.Database.Model -import Internal.Types -import Internal.Utils +import Conduit +import Control.Monad.Logger +import Data.Hashable +import Database.Esqueleto.Experimental +import Database.Persist.Sql hiding (delete, (==.), (||.)) +import Database.Persist.Sqlite hiding (delete, (==.), (||.)) +import Database.Sqlite hiding (Config) +import Internal.Database.Model +import Internal.Types +import Internal.Utils +import RIO hiding (LogFunc, isNothing, on, (^.)) +import RIO.List ((\\)) +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_ c more = runNoLoggingT $ runResourceT - $ withSqlConn (openConnection c) (\backend -> - flip runSqlConn backend $ do - runMigration migrateAll - more - ) +migrate_ c more = + runNoLoggingT $ + runResourceT $ + withSqlConn + (openConnection c) + ( \backend -> + flip runSqlConn backend $ do + runMigration migrateAll + more + ) openConnection :: SqlConfig -> LogFunc -> IO SqlBackend openConnection c logfn = case c of @@ -65,19 +63,23 @@ showBalances :: MonadIO m => SqlPersistT m () showBalances = do xs <- select $ do (accounts :& splits :& txs) <- - from $ table @AccountR - `innerJoin` table @SplitR - `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount) - `innerJoin` table @TransactionR - `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId) + from + $ table @AccountR + `innerJoin` table @SplitR + `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount) + `innerJoin` table @TransactionR + `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId) where_ $ isNothing (txs ^. TransactionRBucket) - &&. ((accounts ^. AccountRFullpath `like` val "asset" ++. (%)) - ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))) + &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%)) + ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%)) + ) groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName) - return ( accounts ^. AccountRFullpath - , accounts ^. AccountRName - , sum_ $ splits ^. SplitRValue) + return + ( accounts ^. AccountRFullpath + , accounts ^. AccountRName + , sum_ $ splits ^. SplitRValue + ) -- TODO super stetchy table printing thingy liftIO $ do putStrLn $ T.unpack $ fmt "Account" "Balance" @@ -91,13 +93,16 @@ showBalances = do toBal = maybe "???" (fmtRational 2) . unValue hashConfig :: Config -> [Int] -hashConfig Config_ { budget = Budget { expenses = xs, income = is } - , statements = ss } = - (hash <$> xs) ++ (hash <$> is) ++ (hash <$> ms) ++ (hash <$> ps) - where - (ms, ps) = partitionEithers $ fmap go ss - go (StmtManual x) = Left x - go (StmtImport x) = Right x +hashConfig + Config_ + { budget = Budget {expenses = xs, income = is} + , statements = ss + } = + (hash <$> xs) ++ (hash <$> is) ++ (hash <$> ms) ++ (hash <$> ps) + where + (ms, ps) = partitionEithers $ fmap go ss + go (StmtManual x) = Left x + go (StmtImport x) = Right x setDiff :: Eq a => [a] -> [a] -> ([a], [a]) -- setDiff = setDiff' (==) @@ -121,8 +126,8 @@ getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl nukeDBHash :: MonadIO m => Int -> SqlPersistT m () nukeDBHash h = delete $ do - c <- from table - where_ (c ^. CommitRHash ==. val h) + c <- from table + where_ (c ^. CommitRHash ==. val h) nukeDBHashes :: MonadIO m => [Int] -> SqlPersistT m () nukeDBHashes = mapM_ nukeDBHash @@ -144,15 +149,15 @@ dumpTbl = select $ from table deleteAccount :: MonadIO m => Entity AccountR -> SqlPersistT m () deleteAccount e = delete $ do - c <- from $ table @AccountR - where_ (c ^. AccountRId ==. val k) + c <- from $ table @AccountR + where_ (c ^. AccountRId ==. val k) where k = entityKey e deleteCurrency :: MonadIO m => Entity CurrencyR -> SqlPersistT m () deleteCurrency e = delete $ do - c <- from $ table @CurrencyR - where_ (c ^. CurrencyRId ==. val k) + c <- from $ table @CurrencyR + where_ (c ^. CurrencyRId ==. val k) where k = entityKey e @@ -168,8 +173,10 @@ updateAccounts ar = do mapM_ insert paths return acntMap -insertFull :: (MonadIO m, PersistStoreWrite b, PersistRecordBackend r b) - => Entity r -> ReaderT b m () +insertFull + :: (MonadIO 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 @@ -191,43 +198,46 @@ toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b toKey = toSqlKey . fromIntegral . hash tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR -tree2Entity t parents name des = Entity (toSqlKey $ fromIntegral h) - $ AccountR name (toPath parents) des +tree2Entity t parents name des = + Entity (toSqlKey $ fromIntegral h) $ + AccountR name (toPath parents) des where - p = AcntPath t (reverse (name:parents)) + p = AcntPath t (reverse (name : parents)) h = hash p - toPath = T.intercalate "/" . (atName t:) . reverse + toPath = T.intercalate "/" . (atName t :) . reverse -tree2Records :: AcntType -> AccountTree +tree2Records + :: AcntType + -> AccountTree -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign))]) tree2Records t = go [] where go ps (Placeholder d n cs) = - let - e = tree2Entity t (fmap snd ps) n d - k = entityKey e - (as, aps, ms) = unzip3 $ fmap (go ((k, n):ps)) cs - a0 = acnt k n (fmap snd ps) d - paths = expand k $ fmap fst ps - in (a0:concat as, paths ++ concat aps, concat ms) - go ps (Account d n) = let e = tree2Entity t (fmap snd ps) n d k = entityKey e - in ( [acnt k n (fmap snd ps) d] - , expand k $ fmap fst ps - , [(AcntPath t $ reverse $ n:fmap snd ps, (k, sign))] - ) - toPath = T.intercalate "/" . (atName t:) . reverse + (as, aps, ms) = unzip3 $ fmap (go ((k, n) : ps)) cs + a0 = acnt k n (fmap snd ps) d + paths = expand k $ fmap fst ps + in (a0 : concat as, paths ++ concat aps, concat ms) + go ps (Account d n) = + let e = tree2Entity t (fmap snd ps) n d + k = entityKey e + in ( [acnt k n (fmap snd ps) d] + , expand k $ fmap fst ps + , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign))] + ) + toPath = T.intercalate "/" . (atName t :) . reverse acnt k n ps = Entity k . AccountR n (toPath ps) - expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0:hs) [0..] + expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..] sign = accountSign t paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)] -paths2IDs = uncurry zip - . first trimNames - . unzip - . L.sortOn fst - . fmap (first pathList) +paths2IDs = + uncurry zip + . first trimNames + . unzip + . L.sortOn fst + . fmap (first pathList) where pathList (AcntPath t ns) = reverse $ atName t : ns @@ -237,41 +247,47 @@ trimNames = fmap fmt . trimAll 0 fmt [] = err "blank path" fmt ys = T.intercalate "_" $ reverse ys trimAll _ [] = [] - trimAll i (y:ys) = case L.foldl' (matchPre i) (y, [], []) ys of - (a, [], bs) -> reverse $ trim i a:bs - (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a:as) + trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of + (a, [], bs) -> reverse $ trim i a : bs + (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as) matchPre i (y, ys, old) new = case (y !? i, new !? i) of (Nothing, Just _) -> case ys of - [] -> (new, [], trim i y:old) - _ -> err "unsorted input" + [] -> (new, [], trim i y : old) + _ -> err "unsorted input" (Just _, Nothing) -> err "unsorted input" (Nothing, Nothing) -> err "duplicated inputs" (Just a, Just b) - | a == b -> (new, y:ys, old) + | a == b -> (new, y : ys, old) | otherwise -> - let next = case ys of - [] -> [trim i y] - _ -> trimAll (i + 1) (reverse $ y:ys) - in (new, [], reverse next ++ old) + let next = case ys of + [] -> [trim i y] + _ -> trimAll (i + 1) (reverse $ y : ys) + in (new, [], reverse next ++ old) trim i = take (i + 1) err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg (!?) :: [a] -> Int -> Maybe a xs !? n - | n < 0 = Nothing - -- Definition adapted from GHC.List - | otherwise = foldr (\x r k -> case k of - 0 -> Just x - _ -> r (k-1)) (const Nothing) xs n + | n < 0 = Nothing + -- Definition adapted from GHC.List + | otherwise = + foldr + ( \x r k -> case k of + 0 -> Just x + _ -> r (k - 1) + ) + (const Nothing) + xs + n flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)] flattenAcntRoot AccountRoot_ {..} = ((IncomeT,) <$> arIncome) - ++ ((ExpenseT,) <$> arExpenses) - ++ ((LiabilityT,) <$> arLiabilities) - ++ ((AssetT,) <$> arAssets) - ++ ((EquityT,) <$> arEquity) + ++ ((ExpenseT,) <$> arExpenses) + ++ ((LiabilityT,) <$> arLiabilities) + ++ ((AssetT,) <$> arAssets) + ++ ((EquityT,) <$> arEquity) indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap) indexAcntRoot r = @@ -289,11 +305,12 @@ getDBState c = do 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 - } + return $ \f -> + DBState + { kmCurrency = cm + , kmAccount = am + , kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c + , kmStatementInterval = intervalMaybeBounds $ statementInterval $ global c + , kmNewCommits = hs + , kmConfigDir = f + } diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 2a391d0..c5628a9 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -1,39 +1,32 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} module Internal.Insert ( insertStatements , insertBudget - ) where + ) +where -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader +import Data.Hashable +import Database.Persist.Class +import Database.Persist.Sql hiding (Single, Statement) +import Internal.Database.Model +import Internal.Statement +import Internal.Types hiding (sign) +import Internal.Utils +import RIO hiding (to) +import qualified RIO.Map as M +import qualified RIO.Text as T +import RIO.Time -import Data.Either -import Data.Hashable -import qualified Data.Map as M -import Data.Maybe -import qualified Data.Text as T -import Data.Time - -import Database.Persist.Class -import Database.Persist.Sql hiding (Single, Statement) - -import Internal.Database.Model -import Internal.Statement -import Internal.Types hiding (sign) -import Internal.Utils - -import Numeric.Natural - -lookupKey :: (Show v, Ord k, Show k, MonadIO m) => M.Map k v -> k -> m (Maybe v) +lookupKey :: (Ord k, Show k, MonadIO m) => M.Map k v -> k -> m (Maybe v) lookupKey m k = do let v = M.lookup k m when (isNothing v) $ - liftIO $ putStrLn $ "key does not exist: " ++ show k + liftIO $ + putStrLn $ + "key does not exist: " ++ show k return v lookupAccount :: MonadIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign)) @@ -56,65 +49,71 @@ lookupCurrency c = do -- intervals expandDatePat :: Bounds -> DatePat -> [Day] -expandDatePat (a, b) (Cron cp) = filter (cronPatternMatches cp) [a..b] -expandDatePat i (Mod mp) = expandModPat mp i +expandDatePat (a, b) (Cron cp) = filter (cronPatternMatches cp) [a .. b] +expandDatePat i (Mod mp) = expandModPat mp i expandModPat :: ModPat -> Bounds -> [Day] -expandModPat ModPat { mpStart = s - , mpBy = b - , mpUnit = u - , mpRepeats = r - } (lower, upper) = - takeWhile (<= upper) - $ (`addFun` start) . (* b') - <$> maybe id (take . fromIntegral) r [0..] - where - start = maybe lower fromGregorian' s - b' = fromIntegral b - addFun = case u of - Day -> addDays - Week -> addDays . (* 7) - Month -> addGregorianMonthsClip - Year -> addGregorianYearsClip +expandModPat + ModPat + { mpStart = s + , mpBy = b + , mpUnit = u + , mpRepeats = r + } + (lower, upper) = + takeWhile (<= upper) $ + (`addFun` start) . (* b') + <$> maybe id (take . fromIntegral) r [0 ..] + where + start = maybe lower fromGregorian' s + b' = fromIntegral b + addFun = case u of + Day -> addDays + Week -> addDays . (* 7) + Month -> addGregorianMonthsClip + Year -> addGregorianYearsClip -- TODO this can be optimized to prevent filtering a bunch of dates for -- one/a few cron patterns cronPatternMatches :: CronPat -> Day -> Bool -cronPatternMatches CronPat { cronWeekly = w - , cronYear = y - , cronMonth = m - , cronDay = d - } x = - yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w - where - testMaybe = maybe True - yMaybe z = testMaybe (mdyPatternMatches testYear (fromIntegral z)) - mdMaybe z = testMaybe (mdyPatternMatches (const Nothing) (fromIntegral z)) - wdMaybe z = testMaybe (`weekdayPatternMatches` z) - (y', m', d') = toGregorian x - testYear z = if z > 99 then Just "year must be 2 digits" else Nothing +cronPatternMatches + CronPat + { cronWeekly = w + , cronYear = y + , cronMonth = m + , cronDay = d + } + x = + yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w + where + testMaybe = maybe True + yMaybe z = testMaybe (mdyPatternMatches testYear (fromIntegral z)) + mdMaybe z = testMaybe (mdyPatternMatches (const Nothing) (fromIntegral z)) + wdMaybe z = testMaybe (`weekdayPatternMatches` z) + (y', m', d') = toGregorian x + testYear z = if z > 99 then Just "year must be 2 digits" else Nothing dayOfWeek_ :: Day -> Weekday dayOfWeek_ d = case dayOfWeek d of - Monday -> Mon - Tuesday -> Tue + Monday -> Mon + Tuesday -> Tue Wednesday -> Wed - Thursday -> Thu - Friday -> Fri - Saturday -> Sat - Sunday -> Sun + Thursday -> Thu + Friday -> Fri + Saturday -> Sat + Sunday -> Sun weekdayPatternMatches :: WeekdayPat -> Weekday -> Bool -weekdayPatternMatches (OnDay x) = (== x) +weekdayPatternMatches (OnDay x) = (== x) weekdayPatternMatches (OnDays xs) = (`elem` xs) -mdyPatternMatches :: (Natural -> Maybe String) -> Natural -> MDYPat -> Bool +mdyPatternMatches :: (Natural -> Maybe String) -> Natural -> MDYPat -> Bool mdyPatternMatches check x p = case p of Single y -> errMaybe (check y) $ x == y Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs - Repeat (RepeatPat { rpStart = s, rpBy = b, rpRepeats = r }) -> - errMaybe (check s) - $ s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r + Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) -> + errMaybe (check s) $ + s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r where errMaybe test rest = maybe rest err test err msg = error $ show p ++ ": " ++ msg @@ -123,13 +122,18 @@ mdyPatternMatches check x p = case p of -- budget insertBudget :: MonadIO m => Budget -> MappingT m () -insertBudget Budget { income = is, expenses = es } = do +insertBudget Budget {income = is, expenses = es} = do mapM_ insertIncome is mapM_ insertExpense es -- TODO this hashes twice (not that it really matters) -whenHash :: Hashable a => MonadIO m => ConfigType -> a - -> (Key CommitR -> MappingT m ()) -> MappingT m () +whenHash + :: Hashable a + => MonadIO m + => ConfigType + -> a + -> (Key CommitR -> MappingT m ()) + -> MappingT m () whenHash t o f = do let h = hash o hs <- asks kmNewCommits @@ -137,34 +141,38 @@ whenHash t o f = do f =<< lift (insert $ CommitR h t) insertIncome :: MonadIO m => Income -> MappingT m () -insertIncome i@Income { incCurrency = cur - , incWhen = dp - , incAccount = from - , incTaxes = ts - } = - whenHash CTIncome i $ \c -> do - case balanceIncome i of - Left m -> liftIO $ print m - 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 +insertIncome + i@Income + { incCurrency = cur + , incWhen = dp + , incAccount = from + , incTaxes = ts + } = + whenHash CTIncome i $ \c -> do + case balanceIncome i of + Left m -> liftIO $ print m + 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 balanceIncome :: Income -> Either T.Text [BalAllocation] -balanceIncome Income { incGross = g - , incPretax = pre - , incTaxes = tax - , incPosttax = post - } = (preRat ++) <$> balancePostTax bal postRat - where - preRat = mapAlloAmts dec2Rat <$> pre - postRat = mapAlloAmts (fmap dec2Rat) <$> post - bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax) +balanceIncome + Income + { incGross = g + , incPretax = pre + , incTaxes = tax + , incPosttax = post + } = (preRat ++) <$> balancePostTax bal postRat + where + preRat = mapAlloAmts dec2Rat <$> pre + postRat = mapAlloAmts (fmap dec2Rat) <$> post + bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax) mapAlloAmts :: (a -> b) -> Allocation a -> Allocation b -mapAlloAmts f a@Allocation { alloAmts = as } = a { alloAmts = fmap f <$> as } +mapAlloAmts f a@Allocation {alloAmts = as} = a {alloAmts = fmap f <$> as} sumAllocations :: [BalAllocation] -> Rational sumAllocations = sum . concatMap (fmap amtValue . alloAmts) @@ -177,63 +185,92 @@ balancePostTax bal as | null as = Left "no allocations to balance" | otherwise = case partitionEithers $ fmap hasVal as of ([([empty], nonmissing)], bs) -> - let s = bal - sumAllocations (nonmissing:bs) in - if s < 0 - then Left "allocations exceed total" - else Right $ mapAmts (empty { amtValue = s }:) nonmissing : bs + let s = bal - sumAllocations (nonmissing : bs) + in if s < 0 + then Left "allocations exceed total" + else Right $ mapAmts (empty {amtValue = s} :) nonmissing : bs ([], _) -> Left "need one blank amount to balance" - _ -> Left "multiple blank amounts present" + _ -> Left "multiple blank amounts present" where - hasVal a@Allocation { alloAmts = xs } = + hasVal a@Allocation {alloAmts = xs} = case partitionEithers $ fmap maybeAmt xs of - ([], bs) -> Right a { alloAmts = bs } - (unbal, bs) -> Left (unbal, a { alloAmts = bs }) - maybeAmt a@Amount { amtValue = Just v } = Right a { amtValue = v } - maybeAmt a = Left a + ([], bs) -> Right a {alloAmts = bs} + (unbal, bs) -> Left (unbal, a {alloAmts = bs}) + maybeAmt a@Amount {amtValue = Just v} = Right a {amtValue = v} + maybeAmt a = Left a -- TODO lens reinvention mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b -mapAmts f a@Allocation { alloAmts = xs } = a { alloAmts = f xs } +mapAmts f a@Allocation {alloAmts = xs} = a {alloAmts = f xs} -allocationToTx :: MonadIO m => AcntID -> Day -> BalAllocation +allocationToTx + :: MonadIO m + => AcntID + -> Day + -> BalAllocation -> MappingT m [(KeyTx, Bucket)] -allocationToTx from day Allocation { alloPath = to - , alloBucket = b - , alloCurrency = cur - , alloAmts = as - } = - fmap (, b) <$> mapM (transferToTx day from to cur) as +allocationToTx + from + day + Allocation + { alloPath = to + , alloBucket = b + , alloCurrency = cur + , alloAmts = as + } = + fmap (,b) <$> mapM (transferToTx day from to cur) as taxToTx :: MonadIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx -taxToTx from day cur Tax { taxAcnt = to, taxValue = v } = +taxToTx from day cur Tax {taxAcnt = to, taxValue = v} = txPair day from to cur (dec2Rat v) "" -transferToTx :: MonadIO m => Day -> AcntID -> AcntID -> T.Text -> BalAmount +transferToTx + :: MonadIO m + => Day + -> AcntID + -> AcntID + -> T.Text + -> BalAmount -> MappingT m KeyTx -transferToTx day from to cur Amount { amtValue = v, amtDesc = d } = +transferToTx day from to cur Amount {amtValue = v, amtDesc = d} = txPair day from to cur v d insertExpense :: MonadIO m => Expense -> MappingT m () -insertExpense e@Expense { expFrom = from - , expTo = to - , expCurrency = cur - , 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 +insertExpense + e@Expense + { expFrom = from + , expTo = to + , expCurrency = cur + , 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 -timeAmountToTx :: MonadIO m => AcntID -> AcntID -> T.Text -> TimeAmount +timeAmountToTx + :: MonadIO m + => AcntID + -> AcntID + -> T.Text + -> TimeAmount -> MappingT m [KeyTx] -timeAmountToTx from to cur TimeAmount { taWhen = dp - , taAmt = Amount { amtValue = v - , amtDesc = d - } } = do - bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval - mapM tx $ expandDatePat bounds dp - where - tx day = txPair day from to cur (dec2Rat v) d +timeAmountToTx + from + to + cur + TimeAmount + { taWhen = dp + , taAmt = + Amount + { amtValue = v + , amtDesc = d + } + } = do + bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval + mapM tx $ expandDatePat bounds dp + where + tx day = txPair day from to cur (dec2Rat v) d -------------------------------------------------------------------------------- -- statements @@ -246,19 +283,21 @@ insertStatement (StmtManual m) = insertManual m insertStatement (StmtImport i) = insertImport i insertManual :: MonadIO m => Manual -> MappingT m () -insertManual m@Manual { manualDate = dp - , manualFrom = from - , manualTo = to - , manualValue = v - , manualCurrency = u - , manualDesc = e - } = do - whenHash CTManual m $ \c -> do - bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval - ts <- mapM tx $ expandDatePat bounds dp - lift $ mapM_ (insertTx c) ts - where - tx day = txPair day from to u (dec2Rat v) e +insertManual + m@Manual + { manualDate = dp + , manualFrom = from + , manualTo = to + , manualValue = v + , manualCurrency = u + , manualDesc = e + } = do + whenHash CTManual m $ \c -> do + bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval + ts <- mapM tx $ expandDatePat bounds dp + lift $ mapM_ (insertTx c) ts + where + tx day = txPair day from to u (dec2Rat v) e insertImport :: MonadIO m => Import -> MappingT m () insertImport i = whenHash CTImport i $ \c -> do @@ -272,39 +311,50 @@ insertImport i = whenHash CTImport i $ \c -> do -------------------------------------------------------------------------------- -- low-level transaction stuff -txPair :: MonadIO m => Day -> AcntID -> AcntID -> T.Text -> Rational -> T.Text +txPair + :: MonadIO m + => Day + -> AcntID + -> AcntID + -> T.Text + -> Rational + -> T.Text -> MappingT m KeyTx txPair day from to cur val desc = resolveTx tx where - split a v = Split { sAcnt = a, sValue = v, sComment = "", sCurrency = cur } - tx = Tx { txDescr = desc - , txDate = day - , txTags = [] - , txSplits = [split from (-val), split to val] - } + split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur} + tx = + Tx + { txDescr = desc + , txDate = day + , txTags = [] + , txSplits = [split from (-val), split to val] + } resolveTx :: MonadIO m => BalTx -> MappingT m KeyTx -resolveTx t@Tx { txSplits = ss } = do +resolveTx t@Tx {txSplits = ss} = do rs <- catMaybes <$> mapM resolveSplit ss - return $ t { txSplits = rs } + return $ t {txSplits = rs} resolveSplit :: MonadIO m => BalSplit -> MappingT m (Maybe KeySplit) -resolveSplit s@Split { sAcnt = p, sCurrency = c, sValue = v } = do +resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do aid <- lookupAccountKey p cid <- lookupCurrency c sign <- lookupAccountSign p -- TODO correct sign here? -- TODO lenses would be nice here return $ case (aid, cid, sign) of - (Just aid', Just cid', Just sign') - -> Just $ s { sAcnt = aid' - , sCurrency = cid' - , sValue = v * fromIntegral (sign2Int sign') - } + (Just aid', Just cid', Just sign') -> + Just $ + s + { sAcnt = aid' + , sCurrency = cid' + , sValue = v * fromIntegral (sign2Int sign') + } _ -> Nothing insertTxBucket :: MonadIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m () -insertTxBucket b c Tx { txDate = d, txDescr = e, txSplits = ss } = do +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 @@ -312,5 +362,5 @@ insertTx :: MonadIO m => Key CommitR -> KeyTx -> SqlPersistT m () insertTx = insertTxBucket Nothing insertSplit :: MonadIO m => Key TransactionR -> KeySplit -> SqlPersistT m () -insertSplit t Split { sAcnt = aid, sCurrency = cid, sValue = v, sComment = c } = do +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 4fb2f4b..556265e 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -1,104 +1,105 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -module Internal.Statement - ( readImport - ) where +module Internal.Statement ( + readImport, +) where -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader - -import Data.Bifunctor -import qualified Data.ByteString.Lazy as BL -import Data.Csv -import Data.Either -import qualified Data.List as L -import qualified Data.Map as M -import Data.Maybe -import Data.Ord -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Time -import qualified Data.Vector as V - -import Internal.Database.Model -import Internal.Types -import Internal.Utils - -import Numeric.Natural - -import System.FilePath +import Data.Csv +import Internal.Database.Model +import Internal.Types +import Internal.Utils +import RIO +import qualified RIO.ByteString.Lazy as BL +import RIO.FilePath +import qualified RIO.List as L +import qualified RIO.Map as M +import qualified RIO.Text as T +import RIO.Time +import qualified RIO.Vector as V -- TODO this probably won't scale well (pipes?) readImport :: MonadIO 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 +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 -readImport_ :: MonadIO m => Natural -> Word -> TxOpts -> FilePath - -> MappingT m [TxRecord] +readImport_ :: + MonadIO 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 .: TE.encodeUtf8 toDate - if d == "" - then return Nothing - else do - a <- parseRational toAmountFmt =<< r .: TE.encodeUtf8 toAmount - e <- r .: TE.encodeUtf8 toDesc - os <- M.fromList <$> mapM (\n -> (n, ) <$> r .: TE.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 - ) +matchRecords ms rs = + ( 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 + (es, ts) = + 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) +matchPriorities = + 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 +matchToGroup 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] @@ -117,37 +118,38 @@ zipperSlice :: (a -> b -> Ordering) -> b -> Zipped a -> Either (Zipped a) (Unzip 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 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 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) + 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) 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) + 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) 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 @@ -155,14 +157,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 @@ -171,46 +174,47 @@ matchDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) 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 + 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 findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m matchNonDates :: [Match] -> [TxRecord] -> ([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) - in go (m, u, resetZipper z') rs + 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 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 +balanceSplits 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 = Left s + 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 (:[])) +groupByKey = M.toList . M.fromListWith (++) . fmap (second (: [])) diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index ee091c0..fbadc7e 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -1,73 +1,68 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Internal.Types where -import Data.Fix (Fix (..), foldFix) -import Data.Functor.Foldable (embed) -import qualified Data.Functor.Foldable.TH as TH -import Data.Hashable -import Data.Int -import qualified Data.Map as M -import qualified Data.Text as T -import Data.Time - -import Database.Persist.Sql hiding (In, Statement) - -import Dhall hiding (embed, maybe) -import Dhall.TH - -import Language.Haskell.TH.Syntax (Lift) - -import Text.Read +import Data.Fix (Fix (..), foldFix) +import Data.Functor.Foldable (embed) +import qualified Data.Functor.Foldable.TH as TH +import Database.Persist.Sql hiding (In, Statement) +import Dhall hiding (embed, maybe) +import Dhall.TH +import Language.Haskell.TH.Syntax (Lift) +import RIO +import qualified RIO.Map as M +import qualified RIO.Text as T +import RIO.Time ------------------------------------------------------------------------------- --- | YAML CONFIG +-- YAML CONFIG ------------------------------------------------------------------------------- -makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False }) - [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" - , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit" - , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday" - , MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat" - , MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat" - , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat" - , MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD" - , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate" - , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum" - , MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket" - - , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency" - , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian" - , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM" - , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval" - , SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global" - , SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat" - , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type" - , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type" - , SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal" - , SingleConstructor "TxOpts" "TxOpts" "(./dhall/Types.dhall).TxOpts.Type" - , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type" - , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual" - , SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax" - ] +makeHaskellTypesWith + (defaultGenerateOptions{generateToDhallInstance = False}) + [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" + , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit" + , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday" + , MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat" + , MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat" + , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat" + , MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD" + , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate" + , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum" + , MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket" + , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency" + , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian" + , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM" + , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval" + , SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global" + , SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat" + , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type" + , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type" + , SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal" + , SingleConstructor "TxOpts" "TxOpts" "(./dhall/Types.dhall).TxOpts.Type" + , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type" + , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual" + , SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax" + ] ------------------------------------------------------------------------------- --- | account tree +-- account tree -data AccountTree = Placeholder T.Text T.Text [AccountTree] - | Account T.Text T.Text +data AccountTree + = Placeholder T.Text T.Text [AccountTree] + | Account T.Text T.Text TH.makeBaseFunctor ''AccountTree @@ -75,13 +70,13 @@ deriving instance Generic (AccountTreeF a) deriving instance FromDhall a => FromDhall (AccountTreeF a) data AccountRoot_ a = AccountRoot_ - { arAssets :: ![a] - , arEquity :: ![a] - , arExpenses :: ![a] - , arIncome :: ![a] - , arLiabilities :: ![a] - } - deriving (Generic) + { arAssets :: ![a] + , arEquity :: ![a] + , arExpenses :: ![a] + , arIncome :: ![a] + , arLiabilities :: ![a] + } + deriving (Generic) type AccountRootF = AccountRoot_ (Fix AccountTreeF) @@ -90,55 +85,58 @@ deriving instance FromDhall AccountRootF type AccountRoot = AccountRoot_ AccountTree ------------------------------------------------------------------------------- --- | curencies +-- curencies deriving instance Eq Currency + deriving instance Lift Currency deriving instance Hashable Currency type CurID = T.Text ------------------------------------------------------------------------------- --- | DHALL CONFIG +-- DHALL CONFIG ------------------------------------------------------------------------------- data Config_ a = Config_ - { global :: !Global - , budget :: !Budget - , currencies :: ![Currency] - , statements :: ![Statement] - , accounts :: !a - , sqlConfig :: !SqlConfig - } - deriving (Generic) + { global :: !Global + , budget :: !Budget + , currencies :: ![Currency] + , statements :: ![Statement] + , accounts :: !a + , sqlConfig :: !SqlConfig + } + deriving (Generic) 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_ - { arAssets = unfixTree arAssets - , arEquity = unfixTree arEquity - , arExpenses = unfixTree arExpenses - , arIncome = unfixTree arIncome - , arLiabilities = unfixTree arLiabilities - } + a' = + AccountRoot_ + { arAssets = unfixTree arAssets + , arEquity = unfixTree arEquity + , arExpenses = unfixTree arExpenses + , arIncome = unfixTree arIncome + , arLiabilities = unfixTree arLiabilities + } unfixTree f = foldFix embed <$> f a instance FromDhall a => FromDhall (Config_ a) ------------------------------------------------------------------------------- --- | accounts +-- accounts type AcntID = T.Text -------------------------------------------------------------------------------- --- | Time Patterns (for assigning when budget events will happen) +-- Time Patterns (for assigning when budget events will happen) deriving instance Eq TimeUnit + deriving instance Hashable TimeUnit deriving instance Eq Weekday @@ -165,16 +163,17 @@ 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'} = compare y y' - <> compare m m' - <> compare d d' + compare + 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' + compare + GregorianM{gmYear = y, gmMonth = m} + GregorianM{gmYear = y', gmMonth = m'} = compare y y' <> compare m m' deriving instance Eq ModPat deriving instance Hashable ModPat @@ -186,99 +185,101 @@ deriving instance Eq DatePat deriving instance Hashable DatePat -------------------------------------------------------------------------------- --- | Budget (projecting into the future) +-- Budget (projecting into the future) data Income = Income - { incGross :: !Decimal - , incCurrency :: !CurID - , incWhen :: !DatePat - , incAccount :: !AcntID - , incPretax :: ![Allocation Decimal] - , incTaxes :: ![Tax] - , incPosttax :: ![Allocation (Maybe Decimal)] - } - deriving (Eq, Hashable, Generic, FromDhall) + { incGross :: !Decimal + , incCurrency :: !CurID + , incWhen :: !DatePat + , incAccount :: !AcntID + , incPretax :: ![Allocation Decimal] + , incTaxes :: ![Tax] + , incPosttax :: ![Allocation (Maybe Decimal)] + } + deriving (Eq, Hashable, Generic, FromDhall) data Budget = Budget - { income :: ![Income] - , expenses :: ![Expense] - } - deriving (Generic, FromDhall) + { income :: ![Income] + , expenses :: ![Expense] + } + deriving (Generic, FromDhall) deriving instance Eq Tax deriving instance Hashable Tax data Amount v = Amount - { amtValue :: !v - , amtDesc :: !T.Text - } deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall) + { amtValue :: !v + , amtDesc :: !T.Text + } + deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall) data Allocation v = Allocation - { alloPath :: !AcntID - , alloBucket :: !Bucket - , alloAmts :: ![Amount v] - , alloCurrency :: !CurID - } - deriving (Eq, Hashable, Generic, FromDhall) + { alloPath :: !AcntID + , alloBucket :: !Bucket + , alloAmts :: ![Amount v] + , alloCurrency :: !CurID + } + deriving (Eq, Hashable, Generic, FromDhall) deriving instance Eq Bucket deriving instance Hashable Bucket deriving instance Show Bucket data TimeAmount = TimeAmount - { taWhen :: !DatePat - , taAmt :: Amount Decimal - } - deriving (Eq, Hashable, Generic, FromDhall) + { taWhen :: !DatePat + , taAmt :: Amount Decimal + } + deriving (Eq, Hashable, Generic, FromDhall) data Expense = Expense - { expFrom :: !AcntID - , expTo :: !AcntID - , expBucket :: !Bucket - , expAmounts :: ![TimeAmount] - , expCurrency :: !CurID - } - deriving (Eq, Hashable, Generic, FromDhall) + { expFrom :: !AcntID + , expTo :: !AcntID + , expBucket :: !Bucket + , expAmounts :: ![TimeAmount] + , expCurrency :: !CurID + } + deriving (Eq, Hashable, Generic, FromDhall) -------------------------------------------------------------------------------- --- | Statements (data from the past) +-- Statements (data from the past) -data Statement = StmtManual Manual - | StmtImport Import - deriving (Generic, FromDhall) +data Statement + = StmtManual Manual + | StmtImport Import + deriving (Generic, FromDhall) deriving instance Hashable Manual data Split a v c = Split - { sAcnt :: !a - , sValue :: !v - , sCurrency :: !c - , sComment :: !T.Text - } - deriving (Eq, Generic, Hashable, Show, FromDhall) + { sAcnt :: !a + , sValue :: !v + , sCurrency :: !c + , sComment :: !T.Text + } + deriving (Eq, Generic, Hashable, Show, FromDhall) type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur data Tx s = Tx - { txDescr :: !T.Text - , txDate :: !Day - , txTags :: ![T.Text] - , txSplits :: ![s] - } - deriving (Generic) + { txDescr :: !T.Text + , txDate :: !Day + , txTags :: ![T.Text] + , txSplits :: ![s] + } + deriving (Generic) type ExpTx = Tx ExpSplit -instance FromDhall ExpTx where +instance FromDhall ExpTx data Import = Import - { impPaths :: ![FilePath] - , impMatches :: ![Match] - , impDelim :: !Word - , impTxOpts :: !TxOpts - , impSkipLines :: !Natural - } - deriving (Hashable, Generic, FromDhall) + { impPaths :: ![FilePath] + , impMatches :: ![Match] + , impDelim :: !Word + , impTxOpts :: !TxOpts + , impSkipLines :: !Natural + } + deriving (Hashable, Generic, FromDhall) deriving instance Eq MatchVal deriving instance Hashable MatchVal @@ -294,162 +295,169 @@ deriving instance Show MatchDate -- TODO this just looks silly...but not sure how to simplify it instance Ord MatchYMD where - compare (Y y) (Y y') = compare y y' - compare (YM g) (YM g') = compare g g' - compare (YMD g) (YMD g') = compare g g' - compare (Y y) (YM g) = compare y (gmYear g) <> LT - compare (Y y) (YMD g) = compare y (gYear g) <> LT - compare (YM g) (Y y') = compare (gmYear g) y' <> GT - compare (YMD g) (Y y') = compare (gYear g) y' <> GT - compare (YM g) (YMD g') = compare g (gregM g') <> LT - compare (YMD g) (YM g') = compare (gregM g) g' <> GT + compare (Y y) (Y y') = compare y y' + compare (YM g) (YM g') = compare g g' + compare (YMD g) (YMD g') = compare g g' + compare (Y y) (YM g) = compare y (gmYear g) <> LT + compare (Y y) (YMD g) = compare y (gYear g) <> LT + compare (YM g) (Y y') = compare (gmYear g) y' <> GT + compare (YMD g) (Y y') = compare (gYear g) y' <> GT + compare (YM g) (YMD g') = compare g (gregM g') <> LT + 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' - compare (In d r) (In d' r') = compare d d' <> compare r r' - compare (On d) (In d' _) = compare d d' <> LT - compare (In d _) (On d') = compare d d' <> GT + compare (On d) (On d') = compare d d' + compare (In d r) (In d' r') = compare d d' <> compare r r' + compare (On d) (In d' _) = compare d d' <> LT + 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 -data SplitText t = ConstT !t - | LookupT !T.Text - | MapT (FieldMap T.Text t) - | Map2T (FieldMap (T.Text, T.Text) t) - deriving (Eq, Generic, Hashable, Show, FromDhall) +{- | 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 + | MapT (FieldMap T.Text t) + | Map2T (FieldMap (T.Text, T.Text) t) + deriving (Eq, Generic, Hashable, Show, FromDhall) type SplitCur = SplitText CurID type SplitAcnt = SplitText AcntID data Field k v = Field - { fKey :: !k - , fVal :: !v - } - deriving (Show, Eq, Hashable, Generic, FromDhall) + { fKey :: !k + , fVal :: !v + } + deriving (Show, Eq, Hashable, Generic, FromDhall) type FieldMap k v = Field k (M.Map k v) -data MatchOther = Desc (Field T.Text T.Text) - | Val (Field T.Text MatchVal) - deriving (Show, Eq, Hashable, Generic, FromDhall) +data MatchOther + = Desc (Field T.Text T.Text) + | Val (Field T.Text MatchVal) + deriving (Show, Eq, Hashable, Generic, FromDhall) data ToTx = ToTx - { ttCurrency :: !SplitCur - , ttPath :: !SplitAcnt - , ttSplit :: ![ExpSplit] - } - deriving (Eq, Generic, Hashable, Show, FromDhall) + { ttCurrency :: !SplitCur + , ttPath :: !SplitAcnt + , ttSplit :: ![ExpSplit] + } + deriving (Eq, Generic, Hashable, Show, FromDhall) data Match = Match - { mDate :: Maybe MatchDate - , mVal :: MatchVal - , mDesc :: Maybe Text - , mOther :: ![MatchOther] - , mTx :: Maybe ToTx - , mTimes :: Maybe Natural - , mPriority :: !Integer - } - deriving (Eq, Generic, Hashable, Show, FromDhall) + { mDate :: Maybe MatchDate + , mVal :: MatchVal + , mDesc :: Maybe Text + , mOther :: ![MatchOther] + , mTx :: Maybe ToTx + , mTimes :: Maybe Natural + , mPriority :: !Integer + } + deriving (Eq, Generic, Hashable, Show, FromDhall) deriving instance Eq TxOpts deriving instance Hashable TxOpts deriving instance Show TxOpts -------------------------------------------------------------------------------- --- | Specialized dhall types +-- Specialized dhall types deriving instance Eq Decimal + deriving instance Hashable Decimal deriving instance Show Decimal -------------------------------------------------------------------------------- --- | database cache types +-- database cache types data ConfigHashes = ConfigHashes - { chIncome :: ![Int] - , chExpense :: ![Int] - , chManual :: ![Int] - , chImport :: ![Int] - } + { chIncome :: ![Int] + , chExpense :: ![Int] + , chManual :: ![Int] + , chImport :: ![Int] + } data ConfigType = CTIncome | CTExpense | CTManual | CTImport - deriving (Eq, Show, Read, Enum) + deriving (Eq, Show, Read, Enum) instance PersistFieldSql ConfigType where - sqlType _ = SqlString + sqlType _ = SqlString instance PersistField ConfigType where - toPersistValue = PersistText . T.pack . show - -- TODO these error messages *might* be good enough? - fromPersistValue (PersistText v) = - maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v - fromPersistValue _ = Left "wrong type" + toPersistValue = PersistText . T.pack . show + + -- TODO these error messages *might* be good enough? + fromPersistValue (PersistText v) = + maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v + fromPersistValue _ = Left "wrong type" ------------------------------------------------------------------------------- --- | misc +-- misc -data AcntType = AssetT - | EquityT - | ExpenseT - | IncomeT - | LiabilityT - deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall) +data AcntType + = AssetT + | EquityT + | ExpenseT + | IncomeT + | LiabilityT + deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall) atName :: AcntType -> T.Text -atName AssetT = "asset" -atName EquityT = "equity" -atName ExpenseT = "expense" -atName IncomeT = "income" +atName AssetT = "asset" +atName EquityT = "equity" +atName ExpenseT = "expense" +atName IncomeT = "income" atName LiabilityT = "liability" data AcntPath = AcntPath - { apType :: !AcntType - , apChildren :: ![T.Text] - } deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall) + { apType :: !AcntType + , apChildren :: ![T.Text] + } + deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall) data TxRecord = TxRecord - { trDate :: !Day - , trAmount :: !Rational - , trDesc :: !T.Text - , trOther :: M.Map T.Text T.Text - } - deriving (Show, Eq, Ord) + { trDate :: !Day + , trAmount :: !Rational + , trDesc :: !T.Text + , trOther :: M.Map T.Text T.Text + } + deriving (Show, Eq, Ord) type Bounds = (Day, Day) type MaybeBounds = (Maybe Day, Maybe Day) data Keyed a = Keyed - { kKey :: !Int64 - , kVal :: !a - } - deriving (Eq, Show, Functor) + { kKey :: !Int64 + , kVal :: !a + } + deriving (Eq, Show, Functor) -data Tree a = Branch !a ![Tree a] | Leaf !a deriving Show +data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show) data AcntSign = Credit | Debit - deriving (Show) + deriving (Show) sign2Int :: AcntSign -> Int -sign2Int Debit = 1 +sign2Int Debit = 1 sign2Int Credit = 1 accountSign :: AcntType -> AcntSign -accountSign AssetT = Debit -accountSign ExpenseT = Debit -accountSign IncomeT = Credit +accountSign AssetT = Debit +accountSign ExpenseT = Debit +accountSign IncomeT = Credit accountSign LiabilityT = Credit -accountSign EquityT = Credit +accountSign EquityT = Credit type RawAmount = Amount (Maybe Rational) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 82fcc9f..b9a5b44 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -1,23 +1,17 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module Internal.Utils where -import Data.Bifunctor -import qualified Data.Map as M -import Data.Ratio -import qualified Data.Text as T -import Data.Time - -import GHC.Real - -import Numeric.Natural - -import Internal.Types - -import Text.Read -import Text.Regex.TDFA +import GHC.Real +import Internal.Types +import RIO +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 -- when bifunctor fails... thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f) @@ -26,15 +20,19 @@ thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) gregTup :: Gregorian -> (Integer, Int, Int) gregTup g@Gregorian {..} | gYear > 99 = error $ show g ++ ": year must only be two digits" - | otherwise = ( fromIntegral gYear + 2000 - , fromIntegral gMonth - , fromIntegral gDay) + | otherwise = + ( 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" - | otherwise = ( fromIntegral gmYear + 2000 - , fromIntegral gmMonth) + | otherwise = + ( fromIntegral gmYear + 2000 + , fromIntegral gmMonth + ) data MDY_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int @@ -43,21 +41,22 @@ 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 + 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') + 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 + 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 @@ -69,37 +68,42 @@ dateMatches :: MatchDate -> Day -> Bool dateMatches md = (EQ ==) . compareDate md valMatches :: MatchVal -> Rational -> Bool -valMatches MatchVal {..} x = checkMaybe (s ==) mvSign - && checkMaybe (n ==) mvNum - && checkMaybe ((d * p ==) . fromIntegral) mvDen +valMatches MatchVal {..} x = + checkMaybe (s ==) mvSign + && checkMaybe (n ==) mvNum + && checkMaybe ((d * p ==) . fromIntegral) mvDen where (n, d) = properFraction $ abs 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 +evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} = + s + { sAcnt = evalAcnt r a , sValue = evalExp r =<< v - , sCurrency = evalCurrency r c } + , sCurrency = evalCurrency r c + } evalAcnt :: TxRecord -> SplitAcnt -> T.Text -evalAcnt TxRecord { trOther = o } s = case s of +evalAcnt TxRecord {trOther = o} s = case s of ConstT p -> p - LookupT f -> read $ T.unpack $ lookupField f o + 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 + Map2T (Field (f1, f2) m) -> + let k1 = lookupField f1 o + k2 = lookupField f2 o + in lookupErr "account key" (k1, k2) m evalCurrency :: TxRecord -> SplitCur -> T.Text -evalCurrency TxRecord { trOther = o } s = case s of +evalCurrency TxRecord {trOther = o} s = case s of ConstT p -> p - LookupT f -> lookupField f o + 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 + Map2T (Field (f1, f2) m) -> + let k1 = lookupField f1 o + k2 = lookupField f2 o + in lookupErr "currency key" (k1, k2) m errorT :: T.Text -> a errorT = error . T.unpack @@ -110,45 +114,49 @@ lookupField = lookupErr "field" lookupErr :: (Ord k, Show k) => T.Text -> k -> M.Map k v -> 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] + _ -> 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 where - allPass = checkMaybe (`dateMatches` trDate) mDate - && valMatches mVal trAmount - && checkMaybe (=~ trDesc) mDesc - && all (fieldMatches trOther) mOther + 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 fieldMatches dict m = case m of - Val (Field n mv) -> case readRational =<< M.lookup n dict of + Val (Field n mv) -> case readRational =<< M.lookup n dict of (Just v) -> valMatches mv v - _ -> error "you dummy" + _ -> error "you dummy" Desc (Field n md) -> case M.lookup n dict of (Just d) -> d =~ md - _ -> error "you dummy" + _ -> error "you dummy" 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 - } + 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 = "" - } + fromSplit = + Split + { sAcnt = evalAcnt r sa + , sCurrency = evalCurrency r sc + , sValue = Just trAmount + , sComment = "" + } parseRational :: MonadFail m => T.Text -> T.Text -> m Rational parseRational pat s = case ms of @@ -158,16 +166,22 @@ parseRational pat s = case ms of let p = 10 ^ T.length y (k, w) <- readWhole sign x return $ k * (w + d % p) - _ -> msg "malformed decimal" + _ -> msg "malformed decimal" where (_, _, _, ms) = (s =~ pat) :: (T.Text, T.Text, T.Text, [T.Text]) readT what t = case readMaybe $ T.unpack t of Just d -> return $ fromInteger d - _ -> msg $ T.unwords ["could not parse", what, t] - msg m = fail $ T.unpack $ T.concat [ m - , "; pattern = ", pat - , "; query = ", s - ] + _ -> msg $ T.unwords ["could not parse", what, t] + msg m = + fail $ + T.unpack $ + T.concat + [ m + , "; pattern = " + , pat + , "; query = " + , s + ] readSign x | x == "-" = return (-1) | x == "+" || x == "" = return 1 @@ -177,23 +191,25 @@ parseRational pat s = case ms of k <- readSign sign return (k, w) +-- TODO don't use a partial function readRational :: MonadFail m => T.Text -> m Rational -readRational s = case T.splitOn "." s of +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 + [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 where readT = read . T.unpack -- TODO smells like a lens mapTxSplits :: (a -> b) -> Tx a -> Tx b -mapTxSplits f t@Tx { txSplits = ss } = t { txSplits = fmap f ss } +mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss} boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds boundsFromGregorian = bimap fromGregorian' fromGregorian' @@ -208,7 +224,7 @@ 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 } = +intervalMaybeBounds Interval {intStart = s, intEnd = e} = (fromGregorian' <$> s, fromGregorian' <$> e) resolveBounds :: MaybeBounds -> IO Bounds @@ -223,10 +239,10 @@ fmtRational :: Natural -> Rational -> T.Text fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d'] where s = if x >= 0 then "" else "-" - x'@(n:%d) = abs x + x'@(n :% d) = abs x p = 10 ^ precision - n' = toInteger $ div n d - d' = toInteger $ (\(a:%b) -> div a b) ((x' - fromIntegral n') * p) + n' = div n d + d' = (\(a :% b) -> div a b) ((x' - fromIntegral n') * p) txt = T.pack . show pad i c z = T.append (T.replicate (i - T.length z) c) z @@ -242,8 +258,8 @@ rpad c n s = s ++ replicate (n - length s) c evalExp :: TxRecord -> SplitNum -> Maybe Rational evalExp r s = case s of (LookupN t) -> readRational =<< M.lookup t (trOther r) - (ConstN c) -> Just $ dec2Rat c - AmountN -> Just $ trAmount r + (ConstN c) -> Just $ dec2Rat c + AmountN -> Just $ trAmount r dec2Rat :: Decimal -> Rational dec2Rat D {..} = diff --git a/package.yaml b/package.yaml index 9d7e62d..fe911f1 100644 --- a/package.yaml +++ b/package.yaml @@ -21,7 +21,7 @@ description: Please see the README on GitHub at = 4.12 && < 10 -# - rio >= 0.1.22.0 +- rio >= 0.1.21.0 - persistent >= 2.13.3.1 - persistent-sqlite >= 2.13.1.0 - monad-logger >= 0.3.36 @@ -33,15 +33,10 @@ dependencies: - containers >= 0.6.4.1 - ghc >= 9.0.2 - cassava -- bytestring -- vector - regex-tdfa -- utf8-string -- transformers - esqueleto - template-haskell - hashable -- yaml - optparse-applicative - recursion-schemes - data-fix @@ -51,17 +46,14 @@ library: source-dirs: lib/ ghc-options: - -Wall - - -Werror - - -threaded + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wredundant-constraints - -Wpartial-fields - exposed-modules: - - Internal.Config - - Internal.Types - - Internal.Utils - - Internal.Database.Ops - - Internal.Database.Model - - Internal.Insert - - Internal.Statement + - -Werror + - -O2 executables: pwncash: @@ -69,9 +61,14 @@ executables: source-dirs: app ghc-options: - -Wall - - -Werror - - -threaded + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wredundant-constraints - -Wpartial-fields + - -Werror - -O2 + - -threaded dependencies: - budget