ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH use rio modules everywhere and use recommended flags

This commit is contained in:
Nathan Dwarshuis 2023-01-05 22:16:06 -05:00
parent c5e32aee48
commit 20cc4db986
10 changed files with 971 additions and 930 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

155
app/Main.hs
View File

@ -2,106 +2,117 @@
module Main (main) where module Main (main) where
import qualified Data.Text as T import Internal.Config
import Internal.Database.Ops
import Internal.Config import Internal.Insert
import Internal.Database.Ops import Internal.Types
import Internal.Insert import Internal.Utils
import Internal.Types import Options.Applicative
import Internal.Utils import RIO
import RIO.FilePath
import Control.Monad.Trans.Reader import qualified RIO.Text as T
import Options.Applicative
import System.FilePath
main :: IO () main :: IO ()
main = parse =<< execParser o main = parse =<< execParser o
where where
o = info (options <**> helper) o =
( fullDesc info
<> progDesc "Pwn your budget" (options <**> helper)
<> header "pwncash - your budget, your life" ( fullDesc
) <> progDesc "Pwn your budget"
<> header "pwncash - your budget, your life"
)
data Options = Options FilePath Mode data Options = Options FilePath Mode
data Mode = Reset data Mode
= Reset
| DumpCurrencies | DumpCurrencies
| DumpAccounts | DumpAccounts
| DumpAccountKeys | DumpAccountKeys
| Sync | Sync
configFile :: Parser FilePath configFile :: Parser FilePath
configFile = strOption configFile =
( long "config" strOption
<> short 'c' ( long "config"
<> metavar "CONFIG" <> short 'c'
<> value "main.dhall" <> metavar "CONFIG"
<> help "config file to use" <> value "main.dhall"
) <> help "config file to use"
)
options :: Parser Options options :: Parser Options
options = getConf reset options =
<|> getConf dumpCurrencies getConf reset
<|> getConf dumpAccounts <|> getConf dumpCurrencies
<|> getConf dumpAccountKeys <|> getConf dumpAccounts
<|> getConf sync <|> getConf dumpAccountKeys
<|> getConf sync
where where
getConf m = Options <$> configFile <*> m getConf m = Options <$> configFile <*> m
reset :: Parser Mode reset :: Parser Mode
reset = flag' Reset reset =
( long "reset" flag'
<> short 'R' Reset
<> help "Reset the database" ( long "reset"
) <> short 'R'
<> help "Reset the database"
)
dumpCurrencies :: Parser Mode dumpCurrencies :: Parser Mode
dumpCurrencies = flag' DumpCurrencies dumpCurrencies =
( long "currencies" flag'
<> short 'C' DumpCurrencies
<> help "Dump all currencies in the configuration" ( long "currencies"
) <> short 'C'
<> help "Dump all currencies in the configuration"
)
dumpAccounts :: Parser Mode dumpAccounts :: Parser Mode
dumpAccounts = flag' DumpAccounts dumpAccounts =
( long "accounts" flag'
<> short 'A' DumpAccounts
<> help "Dump all accounts in the configuration" ( long "accounts"
) <> short 'A'
<> help "Dump all accounts in the configuration"
)
-- TODO 'alias' is a better name for these -- TODO 'alias' is a better name for these
dumpAccountKeys :: Parser Mode dumpAccountKeys :: Parser Mode
dumpAccountKeys = flag' DumpAccountKeys dumpAccountKeys =
( long "account_keys" flag'
<> short 'K' DumpAccountKeys
<> help "Dump all account keys/aliases" ( long "account_keys"
) <> short 'K'
<> help "Dump all account keys/aliases"
)
sync :: Parser Mode sync :: Parser Mode
sync = flag' Sync sync =
( long "sync" flag'
<> short 'S' Sync
<> help "Sync config to database" ( long "sync"
) <> short 'S'
<> help "Sync config to database"
)
parse :: Options -> IO () parse :: Options -> IO ()
parse (Options c Reset) = do parse (Options c Reset) = do
config <- readConfig c config <- readConfig c
migrate_ (sqlConfig config) nukeTables 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 DumpAccountKeys) = runDumpAccountKeys c
parse (Options c DumpCurrencies) = runDumpCurrencies c parse (Options c DumpCurrencies) = runDumpCurrencies c
parse (Options c Sync) = runSync c parse (Options c Sync) = runSync c
runDumpCurrencies :: FilePath -> IO () runDumpCurrencies :: FilePath -> IO ()
runDumpCurrencies c = do runDumpCurrencies c = do
cs <- currencies <$> readConfig c cs <- currencies <$> readConfig c
putStrLn $ T.unpack $ T.unlines $ fmap fmt cs putStrLn $ T.unpack $ T.unlines $ fmap fmt cs
where where
fmt Currency { curSymbol = s, curFullname = f } = fmt Currency {curSymbol = s, curFullname = f} =
T.concat [s, ": ", f] T.concat [s, ": ", f]
runDumpAccounts :: FilePath -> IO () runDumpAccounts :: FilePath -> IO ()
@ -109,12 +120,13 @@ runDumpAccounts c = do
ar <- accounts <$> readConfig c ar <- accounts <$> readConfig c
mapM_ (\(h, f) -> printTree h $ f ar) ps mapM_ (\(h, f) -> printTree h $ f ar) ps
where where
ps = [ ("Assets", arAssets) ps =
, ("Equity", arEquity) [ ("Assets", arAssets)
, ("Expenses", arExpenses) , ("Equity", arEquity)
, ("Income", arIncome) , ("Expenses", arExpenses)
, ("Liabilities", arLiabilities) , ("Income", arIncome)
] , ("Liabilities", arLiabilities)
]
printTree h ts = do printTree h ts = do
putStrLn h putStrLn h
mapM (go 1) ts mapM (go 1) ts
@ -129,10 +141,11 @@ runDumpAccounts c = do
runDumpAccountKeys :: FilePath -> IO () runDumpAccountKeys :: FilePath -> IO ()
runDumpAccountKeys c = do runDumpAccountKeys c = do
ar <- accounts <$> readConfig c ar <- accounts <$> readConfig c
let ks = paths2IDs let ks =
$ fmap (double . fst) paths2IDs $
$ concatMap (t3 . uncurry tree2Records) fmap (double . fst) $
$ flattenAcntRoot ar concatMap (t3 . uncurry tree2Records) $
flattenAcntRoot ar
mapM_ (uncurry printPair) ks mapM_ (uncurry printPair) ks
where where
printPair i p = do printPair i p = do

24
budget.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 1.12 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 -- see: https://github.com/sol/hpack
@ -26,20 +26,19 @@ source-repository head
library library
exposed-modules: exposed-modules:
Internal.Config Internal.Config
Internal.Types
Internal.Utils
Internal.Database.Ops
Internal.Database.Model Internal.Database.Model
Internal.Database.Ops
Internal.Insert Internal.Insert
Internal.Statement Internal.Statement
Internal.Types
Internal.Utils
other-modules: other-modules:
Paths_budget Paths_budget
hs-source-dirs: hs-source-dirs:
lib/ 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: build-depends:
base >=4.12 && <10 base >=4.12 && <10
, bytestring
, cassava , cassava
, conduit >=1.3.4.2 , conduit >=1.3.4.2
, containers >=0.6.4.1 , containers >=0.6.4.1
@ -56,13 +55,10 @@ library
, persistent-sqlite >=2.13.1.0 , persistent-sqlite >=2.13.1.0
, recursion-schemes , recursion-schemes
, regex-tdfa , regex-tdfa
, rio >=0.1.21.0
, template-haskell , template-haskell
, text >=1.2.5.0 , text >=1.2.5.0
, time >=1.9.3 , time >=1.9.3
, transformers
, utf8-string
, vector
, yaml
default-language: Haskell2010 default-language: Haskell2010
executable pwncash executable pwncash
@ -71,11 +67,10 @@ executable pwncash
Paths_budget Paths_budget
hs-source-dirs: hs-source-dirs:
app 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: build-depends:
base >=4.12 && <10 base >=4.12 && <10
, budget , budget
, bytestring
, cassava , cassava
, conduit >=1.3.4.2 , conduit >=1.3.4.2
, containers >=0.6.4.1 , containers >=0.6.4.1
@ -92,11 +87,8 @@ executable pwncash
, persistent-sqlite >=2.13.1.0 , persistent-sqlite >=2.13.1.0
, recursion-schemes , recursion-schemes
, regex-tdfa , regex-tdfa
, rio >=0.1.21.0
, template-haskell , template-haskell
, text >=1.2.5.0 , text >=1.2.5.0
, time >=1.9.3 , time >=1.9.3
, transformers
, utf8-string
, vector
, yaml
default-language: Haskell2010 default-language: Haskell2010

81
lib/Internal/Config.hs
View File

@ -1,76 +1,21 @@
module Internal.Config module Internal.Config
( readConfig ( readConfig
, readYaml -- , readYaml
) where )
where
import Control.Exception -- import Control.Exception
-- import Control.Lens -- import Data.Yaml
import Dhall hiding (record)
-- import Data.Maybe import Internal.Types
-- 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
readConfig :: FilePath -> IO Config readConfig :: FilePath -> IO Config
readConfig confpath = do 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 unfix <$> inputFile auto confpath
-- typeSubs :: [(T.Text, DC.Expr Src Void)] -- readYaml :: FromJSON a => FilePath -> IO a
-- typeSubs = firstOrder ++ higherOrder -- readYaml p = do
-- where -- r <- decodeFileEither p
-- toVar a = fmap (\n -> (T.pack $ show n, maximum $ expected a)) -- case r of
-- $ listToMaybe $ snd $ splitTyConApp $ typeOf a -- Right a -> return a
-- higherOrder = -- Left e -> throw e
-- [ ("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

61
lib/Internal/Database/Model.hs
View File

@ -1,34 +1,33 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Internal.Database.Model where 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 share
import qualified Data.Text as T [mkPersist sqlSettings, mkMigrate "migrateAll"]
import Data.Time [persistLowerCase|
import Database.Esqueleto.Experimental
import Database.Persist.TH
import Internal.Types
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
CommitR sql=commits CommitR sql=commits
hash Int hash Int
type ConfigType type ConfigType
@ -67,12 +66,12 @@ type AccountMap = M.Map AcntID (AccountRId, AcntSign)
type CurrencyMap = M.Map CurID CurrencyRId type CurrencyMap = M.Map CurID CurrencyRId
data DBState = DBState data DBState = DBState
{ kmCurrency :: !CurrencyMap { kmCurrency :: !CurrencyMap
, kmAccount :: !AccountMap , kmAccount :: !AccountMap
, kmBudgetInterval :: !MaybeBounds , kmBudgetInterval :: !MaybeBounds
, kmStatementInterval :: !MaybeBounds , kmStatementInterval :: !MaybeBounds
, kmNewCommits :: ![Int] , kmNewCommits :: ![Int]
, kmConfigDir :: FilePath , kmConfigDir :: FilePath
} }
type MappingT m a = ReaderT DBState (SqlPersistT m) a type MappingT m a = ReaderT DBState (SqlPersistT m) a

237
lib/Internal/Database/Ops.hs
View File

@ -1,9 +1,9 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Internal.Database.Ops module Internal.Database.Ops
( migrate_ ( migrate_
@ -14,38 +14,36 @@ module Internal.Database.Ops
, tree2Records , tree2Records
, flattenAcntRoot , flattenAcntRoot
, paths2IDs , paths2IDs
)
where
) where import Conduit
import Control.Monad.Logger
import Control.Monad.Logger import Data.Hashable
import Control.Monad.Trans.Reader import Database.Esqueleto.Experimental
import Database.Persist.Sql hiding (delete, (==.), (||.))
import Conduit import Database.Persist.Sqlite hiding (delete, (==.), (||.))
import Database.Sqlite hiding (Config)
import Data.Bifunctor import Internal.Database.Model
import Data.Either import Internal.Types
import Data.Hashable import Internal.Utils
import Data.List ((\\)) import RIO hiding (LogFunc, isNothing, on, (^.))
import qualified Data.List as L import RIO.List ((\\))
import qualified Data.Map as M import qualified RIO.List as L
import qualified Data.Text as T import qualified RIO.Map as M
import qualified RIO.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
migrate_ :: SqlConfig -> SqlPersistT (ResourceT (NoLoggingT IO)) () -> IO () migrate_ :: SqlConfig -> SqlPersistT (ResourceT (NoLoggingT IO)) () -> IO ()
migrate_ c more = runNoLoggingT $ runResourceT migrate_ c more =
$ withSqlConn (openConnection c) (\backend -> runNoLoggingT $
flip runSqlConn backend $ do runResourceT $
runMigration migrateAll withSqlConn
more (openConnection c)
) ( \backend ->
flip runSqlConn backend $ do
runMigration migrateAll
more
)
openConnection :: SqlConfig -> LogFunc -> IO SqlBackend openConnection :: SqlConfig -> LogFunc -> IO SqlBackend
openConnection c logfn = case c of openConnection c logfn = case c of
@ -65,19 +63,23 @@ showBalances :: MonadIO m => SqlPersistT m ()
showBalances = do showBalances = do
xs <- select $ do xs <- select $ do
(accounts :& splits :& txs) <- (accounts :& splits :& txs) <-
from $ table @AccountR from
`innerJoin` table @SplitR $ table @AccountR
`on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount) `innerJoin` table @SplitR
`innerJoin` table @TransactionR `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount)
`on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId) `innerJoin` table @TransactionR
`on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId)
where_ $ where_ $
isNothing (txs ^. TransactionRBucket) isNothing (txs ^. TransactionRBucket)
&&. ((accounts ^. AccountRFullpath `like` val "asset" ++. (%)) &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%))
||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))) ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))
)
groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName) groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName)
return ( accounts ^. AccountRFullpath return
, accounts ^. AccountRName ( accounts ^. AccountRFullpath
, sum_ $ splits ^. SplitRValue) , accounts ^. AccountRName
, sum_ $ splits ^. SplitRValue
)
-- TODO super stetchy table printing thingy -- TODO super stetchy table printing thingy
liftIO $ do liftIO $ do
putStrLn $ T.unpack $ fmt "Account" "Balance" putStrLn $ T.unpack $ fmt "Account" "Balance"
@ -91,13 +93,16 @@ showBalances = do
toBal = maybe "???" (fmtRational 2) . unValue toBal = maybe "???" (fmtRational 2) . unValue
hashConfig :: Config -> [Int] hashConfig :: Config -> [Int]
hashConfig Config_ { budget = Budget { expenses = xs, income = is } hashConfig
, statements = ss } = Config_
(hash <$> xs) ++ (hash <$> is) ++ (hash <$> ms) ++ (hash <$> ps) { budget = Budget {expenses = xs, income = is}
where , statements = ss
(ms, ps) = partitionEithers $ fmap go ss } =
go (StmtManual x) = Left x (hash <$> xs) ++ (hash <$> is) ++ (hash <$> ms) ++ (hash <$> ps)
go (StmtImport x) = Right x 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 :: Eq a => [a] -> [a] -> ([a], [a])
-- setDiff = setDiff' (==) -- setDiff = setDiff' (==)
@ -121,8 +126,8 @@ getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
nukeDBHash :: MonadIO m => Int -> SqlPersistT m () nukeDBHash :: MonadIO m => Int -> SqlPersistT m ()
nukeDBHash h = delete $ do nukeDBHash h = delete $ do
c <- from table c <- from table
where_ (c ^. CommitRHash ==. val h) where_ (c ^. CommitRHash ==. val h)
nukeDBHashes :: MonadIO m => [Int] -> SqlPersistT m () nukeDBHashes :: MonadIO m => [Int] -> SqlPersistT m ()
nukeDBHashes = mapM_ nukeDBHash nukeDBHashes = mapM_ nukeDBHash
@ -144,15 +149,15 @@ dumpTbl = select $ from table
deleteAccount :: MonadIO m => Entity AccountR -> SqlPersistT m () deleteAccount :: MonadIO m => Entity AccountR -> SqlPersistT m ()
deleteAccount e = delete $ do deleteAccount e = delete $ do
c <- from $ table @AccountR c <- from $ table @AccountR
where_ (c ^. AccountRId ==. val k) where_ (c ^. AccountRId ==. val k)
where where
k = entityKey e k = entityKey e
deleteCurrency :: MonadIO m => Entity CurrencyR -> SqlPersistT m () deleteCurrency :: MonadIO m => Entity CurrencyR -> SqlPersistT m ()
deleteCurrency e = delete $ do deleteCurrency e = delete $ do
c <- from $ table @CurrencyR c <- from $ table @CurrencyR
where_ (c ^. CurrencyRId ==. val k) where_ (c ^. CurrencyRId ==. val k)
where where
k = entityKey e k = entityKey e
@ -168,8 +173,10 @@ updateAccounts ar = do
mapM_ insert paths mapM_ insert paths
return acntMap return acntMap
insertFull :: (MonadIO m, PersistStoreWrite b, PersistRecordBackend r b) insertFull
=> Entity r -> ReaderT b m () :: (MonadIO m, PersistStoreWrite b, PersistRecordBackend r b)
=> Entity r
-> ReaderT b m ()
insertFull (Entity k v) = insertKey k v insertFull (Entity k v) = insertKey k v
updateCurrencies :: MonadIO m => [Currency] -> SqlPersistT m CurrencyMap updateCurrencies :: MonadIO m => [Currency] -> SqlPersistT m CurrencyMap
@ -191,43 +198,46 @@ toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
toKey = toSqlKey . fromIntegral . hash toKey = toSqlKey . fromIntegral . hash
tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
tree2Entity t parents name des = Entity (toSqlKey $ fromIntegral h) tree2Entity t parents name des =
$ AccountR name (toPath parents) des Entity (toSqlKey $ fromIntegral h) $
AccountR name (toPath parents) des
where where
p = AcntPath t (reverse (name:parents)) p = AcntPath t (reverse (name : parents))
h = hash p 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))]) -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign))])
tree2Records t = go [] tree2Records t = go []
where where
go ps (Placeholder d n cs) = 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 let e = tree2Entity t (fmap snd ps) n d
k = entityKey e k = entityKey e
in ( [acnt k n (fmap snd ps) d] (as, aps, ms) = unzip3 $ fmap (go ((k, n) : ps)) cs
, expand k $ fmap fst ps a0 = acnt k n (fmap snd ps) d
, [(AcntPath t $ reverse $ n:fmap snd ps, (k, sign))] paths = expand k $ fmap fst ps
) in (a0 : concat as, paths ++ concat aps, concat ms)
toPath = T.intercalate "/" . (atName t:) . reverse 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) 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 sign = accountSign t
paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)] paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
paths2IDs = uncurry zip paths2IDs =
. first trimNames uncurry zip
. unzip . first trimNames
. L.sortOn fst . unzip
. fmap (first pathList) . L.sortOn fst
. fmap (first pathList)
where where
pathList (AcntPath t ns) = reverse $ atName t : ns pathList (AcntPath t ns) = reverse $ atName t : ns
@ -237,41 +247,47 @@ trimNames = fmap fmt . trimAll 0
fmt [] = err "blank path" fmt [] = err "blank path"
fmt ys = T.intercalate "_" $ reverse ys fmt ys = T.intercalate "_" $ reverse ys
trimAll _ [] = [] trimAll _ [] = []
trimAll i (y:ys) = case L.foldl' (matchPre i) (y, [], []) ys of trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
(a, [], bs) -> reverse $ trim i a:bs (a, [], bs) -> reverse $ trim i a : bs
(a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a:as) (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
matchPre i (y, ys, old) new = case (y !? i, new !? i) of matchPre i (y, ys, old) new = case (y !? i, new !? i) of
(Nothing, Just _) -> (Nothing, Just _) ->
case ys of case ys of
[] -> (new, [], trim i y:old) [] -> (new, [], trim i y : old)
_ -> err "unsorted input" _ -> err "unsorted input"
(Just _, Nothing) -> err "unsorted input" (Just _, Nothing) -> err "unsorted input"
(Nothing, Nothing) -> err "duplicated inputs" (Nothing, Nothing) -> err "duplicated inputs"
(Just a, Just b) (Just a, Just b)
| a == b -> (new, y:ys, old) | a == b -> (new, y : ys, old)
| otherwise -> | otherwise ->
let next = case ys of let next = case ys of
[] -> [trim i y] [] -> [trim i y]
_ -> trimAll (i + 1) (reverse $ y:ys) _ -> trimAll (i + 1) (reverse $ y : ys)
in (new, [], reverse next ++ old) in (new, [], reverse next ++ old)
trim i = take (i + 1) trim i = take (i + 1)
err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
(!?) :: [a] -> Int -> Maybe a (!?) :: [a] -> Int -> Maybe a
xs !? n xs !? n
| n < 0 = Nothing | n < 0 = Nothing
-- Definition adapted from GHC.List -- Definition adapted from GHC.List
| otherwise = foldr (\x r k -> case k of | otherwise =
0 -> Just x foldr
_ -> r (k-1)) (const Nothing) xs n ( \x r k -> case k of
0 -> Just x
_ -> r (k - 1)
)
(const Nothing)
xs
n
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)] flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
flattenAcntRoot AccountRoot_ {..} = flattenAcntRoot AccountRoot_ {..} =
((IncomeT,) <$> arIncome) ((IncomeT,) <$> arIncome)
++ ((ExpenseT,) <$> arExpenses) ++ ((ExpenseT,) <$> arExpenses)
++ ((LiabilityT,) <$> arLiabilities) ++ ((LiabilityT,) <$> arLiabilities)
++ ((AssetT,) <$> arAssets) ++ ((AssetT,) <$> arAssets)
++ ((EquityT,) <$> arEquity) ++ ((EquityT,) <$> arEquity)
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap) indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap)
indexAcntRoot r = indexAcntRoot r =
@ -289,11 +305,12 @@ getDBState c = do
hs <- updateHashes c hs <- updateHashes c
-- TODO not sure how I feel about this, probably will change this struct alot -- TODO not sure how I feel about this, probably will change this struct alot
-- in the future so whatever...for now -- in the future so whatever...for now
return $ \f -> DBState return $ \f ->
{ kmCurrency = cm DBState
, kmAccount = am { kmCurrency = cm
, kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c , kmAccount = am
, kmStatementInterval = intervalMaybeBounds $ statementInterval $ global c , kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c
, kmNewCommits = hs , kmStatementInterval = intervalMaybeBounds $ statementInterval $ global c
, kmConfigDir = f , kmNewCommits = hs
} , kmConfigDir = f
}

378
lib/Internal/Insert.hs
View File

@ -1,39 +1,32 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module Internal.Insert module Internal.Insert
( insertStatements ( insertStatements
, insertBudget , insertBudget
) where )
where
import Control.Monad import Data.Hashable
import Control.Monad.IO.Class import Database.Persist.Class
import Control.Monad.Trans.Class import Database.Persist.Sql hiding (Single, Statement)
import Control.Monad.Trans.Reader 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 lookupKey :: (Ord k, Show k, MonadIO m) => M.Map k v -> k -> m (Maybe v)
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 m k = do lookupKey m k = do
let v = M.lookup k m let v = M.lookup k m
when (isNothing v) $ when (isNothing v) $
liftIO $ putStrLn $ "key does not exist: " ++ show k liftIO $
putStrLn $
"key does not exist: " ++ show k
return v return v
lookupAccount :: MonadIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign)) lookupAccount :: MonadIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign))
@ -56,65 +49,71 @@ lookupCurrency c = do
-- intervals -- intervals
expandDatePat :: Bounds -> DatePat -> [Day] expandDatePat :: Bounds -> DatePat -> [Day]
expandDatePat (a, b) (Cron cp) = filter (cronPatternMatches cp) [a..b] expandDatePat (a, b) (Cron cp) = filter (cronPatternMatches cp) [a .. b]
expandDatePat i (Mod mp) = expandModPat mp i expandDatePat i (Mod mp) = expandModPat mp i
expandModPat :: ModPat -> Bounds -> [Day] expandModPat :: ModPat -> Bounds -> [Day]
expandModPat ModPat { mpStart = s expandModPat
, mpBy = b ModPat
, mpUnit = u { mpStart = s
, mpRepeats = r , mpBy = b
} (lower, upper) = , mpUnit = u
takeWhile (<= upper) , mpRepeats = r
$ (`addFun` start) . (* b') }
<$> maybe id (take . fromIntegral) r [0..] (lower, upper) =
where takeWhile (<= upper) $
start = maybe lower fromGregorian' s (`addFun` start) . (* b')
b' = fromIntegral b <$> maybe id (take . fromIntegral) r [0 ..]
addFun = case u of where
Day -> addDays start = maybe lower fromGregorian' s
Week -> addDays . (* 7) b' = fromIntegral b
Month -> addGregorianMonthsClip addFun = case u of
Year -> addGregorianYearsClip Day -> addDays
Week -> addDays . (* 7)
Month -> addGregorianMonthsClip
Year -> addGregorianYearsClip
-- TODO this can be optimized to prevent filtering a bunch of dates for -- TODO this can be optimized to prevent filtering a bunch of dates for
-- one/a few cron patterns -- one/a few cron patterns
cronPatternMatches :: CronPat -> Day -> Bool cronPatternMatches :: CronPat -> Day -> Bool
cronPatternMatches CronPat { cronWeekly = w cronPatternMatches
, cronYear = y CronPat
, cronMonth = m { cronWeekly = w
, cronDay = d , cronYear = y
} x = , cronMonth = m
yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w , cronDay = d
where }
testMaybe = maybe True x =
yMaybe z = testMaybe (mdyPatternMatches testYear (fromIntegral z)) yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w
mdMaybe z = testMaybe (mdyPatternMatches (const Nothing) (fromIntegral z)) where
wdMaybe z = testMaybe (`weekdayPatternMatches` z) testMaybe = maybe True
(y', m', d') = toGregorian x yMaybe z = testMaybe (mdyPatternMatches testYear (fromIntegral z))
testYear z = if z > 99 then Just "year must be 2 digits" else Nothing 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_ :: Day -> Weekday
dayOfWeek_ d = case dayOfWeek d of dayOfWeek_ d = case dayOfWeek d of
Monday -> Mon Monday -> Mon
Tuesday -> Tue Tuesday -> Tue
Wednesday -> Wed Wednesday -> Wed
Thursday -> Thu Thursday -> Thu
Friday -> Fri Friday -> Fri
Saturday -> Sat Saturday -> Sat
Sunday -> Sun Sunday -> Sun
weekdayPatternMatches :: WeekdayPat -> Weekday -> Bool weekdayPatternMatches :: WeekdayPat -> Weekday -> Bool
weekdayPatternMatches (OnDay x) = (== x) weekdayPatternMatches (OnDay x) = (== x)
weekdayPatternMatches (OnDays xs) = (`elem` xs) 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 mdyPatternMatches check x p = case p of
Single y -> errMaybe (check y) $ x == y Single y -> errMaybe (check y) $ x == y
Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs
Repeat (RepeatPat { rpStart = s, rpBy = b, rpRepeats = r }) -> Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) ->
errMaybe (check s) errMaybe (check s) $
$ s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
where where
errMaybe test rest = maybe rest err test errMaybe test rest = maybe rest err test
err msg = error $ show p ++ ": " ++ msg err msg = error $ show p ++ ": " ++ msg
@ -123,13 +122,18 @@ mdyPatternMatches check x p = case p of
-- budget -- budget
insertBudget :: MonadIO m => Budget -> MappingT m () insertBudget :: MonadIO m => Budget -> MappingT m ()
insertBudget Budget { income = is, expenses = es } = do insertBudget Budget {income = is, expenses = es} = do
mapM_ insertIncome is mapM_ insertIncome is
mapM_ insertExpense es mapM_ insertExpense es
-- TODO this hashes twice (not that it really matters) -- TODO this hashes twice (not that it really matters)
whenHash :: Hashable a => MonadIO m => ConfigType -> a whenHash
-> (Key CommitR -> MappingT m ()) -> MappingT m () :: Hashable a
=> MonadIO m
=> ConfigType
-> a
-> (Key CommitR -> MappingT m ())
-> MappingT m ()
whenHash t o f = do whenHash t o f = do
let h = hash o let h = hash o
hs <- asks kmNewCommits hs <- asks kmNewCommits
@ -137,34 +141,38 @@ whenHash t o f = do
f =<< lift (insert $ CommitR h t) f =<< lift (insert $ CommitR h t)
insertIncome :: MonadIO m => Income -> MappingT m () insertIncome :: MonadIO m => Income -> MappingT m ()
insertIncome i@Income { incCurrency = cur insertIncome
, incWhen = dp i@Income
, incAccount = from { incCurrency = cur
, incTaxes = ts , incWhen = dp
} = , incAccount = from
whenHash CTIncome i $ \c -> do , incTaxes = ts
case balanceIncome i of } =
Left m -> liftIO $ print m whenHash CTIncome i $ \c -> do
Right as -> do case balanceIncome i of
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval Left m -> liftIO $ print m
forM_ (expandDatePat bounds dp) $ \day -> do Right as -> do
alloTx <- concat <$> mapM (allocationToTx from day) as bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
taxTx <- fmap (, Fixed) <$> mapM (taxToTx from day cur) ts forM_ (expandDatePat bounds dp) $ \day -> do
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx 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 -> Either T.Text [BalAllocation]
balanceIncome Income { incGross = g balanceIncome
, incPretax = pre Income
, incTaxes = tax { incGross = g
, incPosttax = post , incPretax = pre
} = (preRat ++) <$> balancePostTax bal postRat , incTaxes = tax
where , incPosttax = post
preRat = mapAlloAmts dec2Rat <$> pre } = (preRat ++) <$> balancePostTax bal postRat
postRat = mapAlloAmts (fmap dec2Rat) <$> post where
bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax) preRat = mapAlloAmts dec2Rat <$> pre
postRat = mapAlloAmts (fmap dec2Rat) <$> post
bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax)
mapAlloAmts :: (a -> b) -> Allocation a -> Allocation b 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 :: [BalAllocation] -> Rational
sumAllocations = sum . concatMap (fmap amtValue . alloAmts) sumAllocations = sum . concatMap (fmap amtValue . alloAmts)
@ -177,63 +185,92 @@ balancePostTax bal as
| null as = Left "no allocations to balance" | null as = Left "no allocations to balance"
| otherwise = case partitionEithers $ fmap hasVal as of | otherwise = case partitionEithers $ fmap hasVal as of
([([empty], nonmissing)], bs) -> ([([empty], nonmissing)], bs) ->
let s = bal - sumAllocations (nonmissing:bs) in let s = bal - sumAllocations (nonmissing : bs)
if s < 0 in if s < 0
then Left "allocations exceed total" then Left "allocations exceed total"
else Right $ mapAmts (empty { amtValue = s }:) nonmissing : bs else Right $ mapAmts (empty {amtValue = s} :) nonmissing : bs
([], _) -> Left "need one blank amount to balance" ([], _) -> Left "need one blank amount to balance"
_ -> Left "multiple blank amounts present" _ -> Left "multiple blank amounts present"
where where
hasVal a@Allocation { alloAmts = xs } = hasVal a@Allocation {alloAmts = xs} =
case partitionEithers $ fmap maybeAmt xs of case partitionEithers $ fmap maybeAmt xs of
([], bs) -> Right a { alloAmts = bs } ([], bs) -> Right a {alloAmts = bs}
(unbal, bs) -> Left (unbal, a { alloAmts = bs }) (unbal, bs) -> Left (unbal, a {alloAmts = bs})
maybeAmt a@Amount { amtValue = Just v } = Right a { amtValue = v } maybeAmt a@Amount {amtValue = Just v} = Right a {amtValue = v}
maybeAmt a = Left a maybeAmt a = Left a
-- TODO lens reinvention -- TODO lens reinvention
mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b 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)] -> MappingT m [(KeyTx, Bucket)]
allocationToTx from day Allocation { alloPath = to allocationToTx
, alloBucket = b from
, alloCurrency = cur day
, alloAmts = as Allocation
} = { alloPath = to
fmap (, b) <$> mapM (transferToTx day from to cur) as , 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 :: 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) "" 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 -> 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 txPair day from to cur v d
insertExpense :: MonadIO m => Expense -> MappingT m () insertExpense :: MonadIO m => Expense -> MappingT m ()
insertExpense e@Expense { expFrom = from insertExpense
, expTo = to e@Expense
, expCurrency = cur { expFrom = from
, expBucket = buc , expTo = to
, expAmounts = as , expCurrency = cur
} = do , expBucket = buc
whenHash CTExpense e $ \c -> do , expAmounts = as
ts <- concat <$> mapM (timeAmountToTx from to cur) as } = do
lift $ mapM_ (insertTxBucket (Just buc) c) ts 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] -> MappingT m [KeyTx]
timeAmountToTx from to cur TimeAmount { taWhen = dp timeAmountToTx
, taAmt = Amount { amtValue = v from
, amtDesc = d to
} } = do cur
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval TimeAmount
mapM tx $ expandDatePat bounds dp { taWhen = dp
where , taAmt =
tx day = txPair day from to cur (dec2Rat v) d 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 -- statements
@ -246,19 +283,21 @@ insertStatement (StmtManual m) = insertManual m
insertStatement (StmtImport i) = insertImport i insertStatement (StmtImport i) = insertImport i
insertManual :: MonadIO m => Manual -> MappingT m () insertManual :: MonadIO m => Manual -> MappingT m ()
insertManual m@Manual { manualDate = dp insertManual
, manualFrom = from m@Manual
, manualTo = to { manualDate = dp
, manualValue = v , manualFrom = from
, manualCurrency = u , manualTo = to
, manualDesc = e , manualValue = v
} = do , manualCurrency = u
whenHash CTManual m $ \c -> do , manualDesc = e
bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval } = do
ts <- mapM tx $ expandDatePat bounds dp whenHash CTManual m $ \c -> do
lift $ mapM_ (insertTx c) ts bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
where ts <- mapM tx $ expandDatePat bounds dp
tx day = txPair day from to u (dec2Rat v) e lift $ mapM_ (insertTx c) ts
where
tx day = txPair day from to u (dec2Rat v) e
insertImport :: MonadIO m => Import -> MappingT m () insertImport :: MonadIO m => Import -> MappingT m ()
insertImport i = whenHash CTImport i $ \c -> do insertImport i = whenHash CTImport i $ \c -> do
@ -272,39 +311,50 @@ insertImport i = whenHash CTImport i $ \c -> do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- low-level transaction stuff -- 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 -> MappingT m KeyTx
txPair day from to cur val desc = resolveTx tx txPair day from to cur val desc = resolveTx tx
where where
split a v = Split { sAcnt = a, sValue = v, sComment = "", sCurrency = cur } split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
tx = Tx { txDescr = desc tx =
, txDate = day Tx
, txTags = [] { txDescr = desc
, txSplits = [split from (-val), split to val] , txDate = day
} , txTags = []
, txSplits = [split from (-val), split to val]
}
resolveTx :: MonadIO m => BalTx -> MappingT m KeyTx resolveTx :: MonadIO m => BalTx -> MappingT m KeyTx
resolveTx t@Tx { txSplits = ss } = do resolveTx t@Tx {txSplits = ss} = do
rs <- catMaybes <$> mapM resolveSplit ss rs <- catMaybes <$> mapM resolveSplit ss
return $ t { txSplits = rs } return $ t {txSplits = rs}
resolveSplit :: MonadIO m => BalSplit -> MappingT m (Maybe KeySplit) 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 aid <- lookupAccountKey p
cid <- lookupCurrency c cid <- lookupCurrency c
sign <- lookupAccountSign p sign <- lookupAccountSign p
-- TODO correct sign here? -- TODO correct sign here?
-- TODO lenses would be nice here -- TODO lenses would be nice here
return $ case (aid, cid, sign) of return $ case (aid, cid, sign) of
(Just aid', Just cid', Just sign') (Just aid', Just cid', Just sign') ->
-> Just $ s { sAcnt = aid' Just $
, sCurrency = cid' s
, sValue = v * fromIntegral (sign2Int sign') { sAcnt = aid'
} , sCurrency = cid'
, sValue = v * fromIntegral (sign2Int sign')
}
_ -> Nothing _ -> Nothing
insertTxBucket :: MonadIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m () 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) k <- insert $ TransactionR c d e (fmap (T.pack . show) b)
mapM_ (insertSplit k) ss mapM_ (insertSplit k) ss
@ -312,5 +362,5 @@ insertTx :: MonadIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
insertTx = insertTxBucket Nothing insertTx = insertTxBucket Nothing
insertSplit :: MonadIO m => Key TransactionR -> KeySplit -> SqlPersistT m () 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 insert_ $ SplitR t cid aid c v

262
lib/Internal/Statement.hs
View File

@ -1,104 +1,105 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module Internal.Statement module Internal.Statement (
( readImport readImport,
) where ) where
import Control.Monad.IO.Class import Data.Csv
import Control.Monad.Trans.Reader import Internal.Database.Model
import Internal.Types
import Data.Bifunctor import Internal.Utils
import qualified Data.ByteString.Lazy as BL import RIO
import Data.Csv import qualified RIO.ByteString.Lazy as BL
import Data.Either import RIO.FilePath
import qualified Data.List as L import qualified RIO.List as L
import qualified Data.Map as M import qualified RIO.Map as M
import Data.Maybe import qualified RIO.Text as T
import Data.Ord import RIO.Time
import qualified Data.Text as T import qualified RIO.Vector as V
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
-- TODO this probably won't scale well (pipes?) -- TODO this probably won't scale well (pipes?)
readImport :: MonadIO m => Import -> MappingT m [BalTx] readImport :: MonadIO m => Import -> MappingT m [BalTx]
readImport Import { impPaths = ps readImport
, impMatches = ms Import
, impTxOpts = ns { impPaths = ps
, impDelim = d , impMatches = ms
, impSkipLines = n , impTxOpts = ns
} = do , impDelim = d
rs <- L.sort . concat <$> mapM (readImport_ n d ns) ps , impSkipLines = n
let (ts, es, notfound) = matchRecords ms rs } = do
liftIO $ mapM_ putStrLn $ reverse es rs <- L.sort . concat <$> mapM (readImport_ n d ns) ps
liftIO $ mapM_ print notfound let (ts, es, notfound) = matchRecords ms rs
return ts liftIO $ mapM_ putStrLn $ reverse es
liftIO $ mapM_ print notfound
return ts
readImport_ :: MonadIO m => Natural -> Word -> TxOpts -> FilePath readImport_ ::
-> MappingT m [TxRecord] MonadIO m =>
Natural ->
Word ->
TxOpts ->
FilePath ->
MappingT m [TxRecord]
readImport_ n delim tns p = do readImport_ n delim tns p = do
dir <- asks kmConfigDir dir <- asks kmConfigDir
bs <- liftIO $ BL.readFile $ dir </> p bs <- liftIO $ BL.readFile $ dir </> p
case decodeByNameWithP (parseTxRecord tns) opts $ skip bs of case decodeByNameWithP (parseTxRecord tns) opts $ skip bs of
Left m -> liftIO $ putStrLn m >> return [] Left m -> liftIO $ putStrLn m >> return []
Right (_, v) -> return $ catMaybes $ V.toList v Right (_, v) -> return $ catMaybes $ V.toList v
where where
opts = defaultDecodeOptions { decDelimiter = fromIntegral delim } opts = defaultDecodeOptions{decDelimiter = fromIntegral delim}
skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10 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 -- 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 -- blank dates but will likely want to make this more flexible
parseTxRecord :: TxOpts -> NamedRecord -> Parser (Maybe TxRecord) parseTxRecord :: TxOpts -> NamedRecord -> Parser (Maybe TxRecord)
parseTxRecord TxOpts {..} r = do parseTxRecord TxOpts{..} r = do
d <- r .: TE.encodeUtf8 toDate d <- r .: T.encodeUtf8 toDate
if d == "" if d == ""
then return Nothing then return Nothing
else do else do
a <- parseRational toAmountFmt =<< r .: TE.encodeUtf8 toAmount a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
e <- r .: TE.encodeUtf8 toDesc e <- r .: T.encodeUtf8 toDesc
os <- M.fromList <$> mapM (\n -> (n, ) <$> r .: TE.encodeUtf8 n) toOther os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os return $ Just $ TxRecord d' a e os
matchRecords :: [Match] -> [TxRecord] -> ([BalTx], [String], [Match]) matchRecords :: [Match] -> [TxRecord] -> ([BalTx], [String], [Match])
matchRecords ms rs = ( catMaybes ts matchRecords ms rs =
, T.unpack <$> (es ++ bu) ( catMaybes ts
-- TODO record number of times each match hits for debugging , T.unpack <$> (es ++ bu)
, notfound , -- TODO record number of times each match hits for debugging
) notfound
)
where where
(matched, unmatched, notfound) = matchAll (matchPriorities ms) rs (matched, unmatched, notfound) = matchAll (matchPriorities ms) rs
(es, ts) = partitionEithers (es, ts) =
$ fmap Just . balanceTx <$> catMaybes matched partitionEithers $
fmap Just . balanceTx <$> catMaybes matched
bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched
matchPriorities :: [Match] -> [MatchGroup] matchPriorities :: [Match] -> [MatchGroup]
matchPriorities = fmap matchToGroup matchPriorities =
. L.groupBy (\a b -> mPriority a == mPriority b) fmap matchToGroup
. L.sortOn (Down . mPriority) . L.groupBy (\a b -> mPriority a == mPriority b)
. L.sortOn (Down . mPriority)
matchToGroup :: [Match] -> MatchGroup matchToGroup :: [Match] -> MatchGroup
matchToGroup ms = uncurry MatchGroup matchToGroup ms =
$ first (L.sortOn mDate) uncurry MatchGroup $
$ L.partition (isJust . mDate) ms first (L.sortOn mDate) $
L.partition (isJust . mDate) ms
-- TDOO could use a better struct to flatten the maybe date subtype -- TDOO could use a better struct to flatten the maybe date subtype
data MatchGroup = MatchGroup data MatchGroup = MatchGroup
{ mgDate :: [Match] { mgDate :: [Match]
, mgNoDate :: [Match] , mgNoDate :: [Match]
} deriving (Show) }
deriving (Show)
data Zipped a = Zipped ![a] ![a] 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 zipperSlice f x = go
where where
go z@(Zipped _ []) = Left z go z@(Zipped _ []) = Left z
go z@(Zipped bs (a:as)) = case f a x of go z@(Zipped bs (a : as)) = case f a x of
GT -> go $ Zipped (a:bs) as GT -> go $ Zipped (a : bs) as
EQ -> Right $ goEq (Unzipped bs [a] as) EQ -> Right $ goEq (Unzipped bs [a] as)
LT -> Left z LT -> Left z
goEq z@(Unzipped _ _ []) = z goEq z@(Unzipped _ _ []) = z
goEq z@(Unzipped bs cs (a:as)) = case f a x of goEq z@(Unzipped bs cs (a : as)) = case f a x of
GT -> goEq $ Unzipped (a:bs) cs as GT -> goEq $ Unzipped (a : bs) cs as
EQ -> goEq $ Unzipped bs (a:cs) as EQ -> goEq $ Unzipped bs (a : cs) as
LT -> z LT -> z
zipperMatch :: Unzipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx)) zipperMatch :: Unzipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
zipperMatch (Unzipped bs cs as) x = go [] cs zipperMatch (Unzipped bs cs as) x = go [] cs
where where
go _ [] = (Zipped bs $ cs ++ as, Nothing) go _ [] = (Zipped bs $ cs ++ as, Nothing)
go prev (m:ms) = case matches m x of go prev (m : ms) = case matches m x of
Nothing -> go (m:prev) ms Nothing -> go (m : prev) ms
res@(Just _) -> let ps = reverse prev res@(Just _) ->
ms' = maybe ms (:ms) (matchDec m) in let ps = reverse prev
(Zipped bs $ ps ++ ms' ++ as, res) ms' = maybe ms (: ms) (matchDec m)
in (Zipped bs $ ps ++ ms' ++ as, res)
zipperMatch' :: Zipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx)) zipperMatch' :: Zipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
zipperMatch' z x = go z zipperMatch' z x = go z
where where
go (Zipped bs (a:as)) = case matches a x of go (Zipped bs (a : as)) = case matches a x of
Nothing -> go (Zipped (a:bs) as) Nothing -> go (Zipped (a : bs) as)
res -> (Zipped (maybe bs (:bs) $ matchDec a) as, res) res -> (Zipped (maybe bs (: bs) $ matchDec a) as, res)
go z' = (z', Nothing) go z' = (z', Nothing)
matchDec :: Match -> Maybe Match matchDec :: Match -> Maybe Match
matchDec m@Match { mTimes = t } = matchDec m@Match{mTimes = t} =
if t' == Just 0 then Nothing else Just $ m { mTimes = t' } if t' == Just 0 then Nothing else Just $ m{mTimes = t'}
where where
t' = fmap pred t t' = fmap pred t
@ -155,14 +157,15 @@ matchAll :: [MatchGroup] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
matchAll = go ([], []) matchAll = go ([], [])
where where
go (matched, unused) gs rs = case (gs, rs) of go (matched, unused) gs rs = case (gs, rs) of
(_, []) -> (matched, [], unused) (_, []) -> (matched, [], unused)
([], _) -> (matched, rs, unused) ([], _) -> (matched, rs, unused)
(g:gs', _) -> let (ts, unmatched, us) = matchGroup g rs in (g : gs', _) ->
go (ts ++ matched, us ++ unused) gs' unmatched let (ts, unmatched, us) = matchGroup g rs
in go (ts ++ matched, us ++ unused) gs' unmatched
matchGroup :: MatchGroup -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) matchGroup :: MatchGroup -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
matchGroup MatchGroup { mgDate = ds, mgNoDate = ns } rs matchGroup MatchGroup{mgDate = ds, mgNoDate = ns} rs =
= (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un) (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
where where
(md, rest, ud) = matchDates ds rs (md, rest, ud) = matchDates ds rs
(mn, unmatched, un) = matchNonDates ns rest (mn, unmatched, un) = matchNonDates ns rest
@ -171,46 +174,47 @@ matchDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
matchDates ms = go ([], [], initZipper ms) matchDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z) go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z)
go (matched, unmatched, z) (r:rs) = case zipperSlice findDate r z of go (matched, unmatched, z) (r : rs) = case zipperSlice findDate r z of
Left res -> go (matched, r:unmatched, res) rs Left res -> go (matched, r : unmatched, res) rs
Right res -> Right res ->
let (z', p) = zipperMatch res r let (z', p) = zipperMatch res r
(m, u) = case p of (m, u) = case p of
Just p' -> (p':matched, unmatched) Just p' -> (p' : matched, unmatched)
Nothing -> (matched, r:unmatched) Nothing -> (matched, r : unmatched)
in go (m, u, z') rs in go (m, u, z') rs
findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
matchNonDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) matchNonDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
matchNonDates ms = go ([], [], initZipper ms) matchNonDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z) go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z)
go (matched, unmatched, z) (r:rs) = go (matched, unmatched, z) (r : rs) =
let (z', res) = zipperMatch' z r let (z', res) = zipperMatch' z r
(m, u) = case res of (m, u) = case res of
Just x -> (x:matched, unmatched) Just x -> (x : matched, unmatched)
Nothing -> (matched, r:unmatched) Nothing -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs in go (m, u, resetZipper z') rs
balanceTx :: RawTx -> Either T.Text BalTx balanceTx :: RawTx -> Either T.Text BalTx
balanceTx t@Tx { txSplits = ss } = do balanceTx t@Tx{txSplits = ss} = do
bs <- balanceSplits ss bs <- balanceSplits ss
return $ t { txSplits = bs } return $ t{txSplits = bs}
balanceSplits :: [RawSplit] -> Either T.Text [BalSplit] balanceSplits :: [RawSplit] -> Either T.Text [BalSplit]
balanceSplits ss = fmap concat balanceSplits ss =
<$> mapM (uncurry bal) fmap concat
$ groupByKey <$> mapM (uncurry bal)
$ fmap (\s -> (sCurrency s, s)) ss $ groupByKey
$ fmap (\s -> (sCurrency s, s)) ss
where 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 hasValue s = Left s
bal cur rss bal cur rss
| length rss < 2 = Left $ T.append "Need at least two splits to balance: " cur | length rss < 2 = Left $ T.append "Need at least two splits to balance: " cur
| otherwise = case partitionEithers $ fmap hasValue rss of | otherwise = case partitionEithers $ fmap hasValue rss of
([noVal], val) -> Right $ noVal { sValue = foldr (\s x -> x - sValue s) 0 val } : val ([noVal], val) -> Right $ noVal{sValue = foldr (\s x -> x - sValue s) 0 val} : val
([], val) -> Right val ([], val) -> Right val
_ -> Left $ T.append "Exactly one split must be blank: " cur _ -> Left $ T.append "Exactly one split must be blank: " cur
groupByKey :: Ord k => [(k, v)] -> [(k, [v])] groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
groupByKey = M.toList . M.fromListWith (++) . fmap (second (:[])) groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))

488
lib/Internal/Types.hs
View File

@ -1,73 +1,68 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Internal.Types where module Internal.Types where
import Data.Fix (Fix (..), foldFix) import Data.Fix (Fix (..), foldFix)
import Data.Functor.Foldable (embed) import Data.Functor.Foldable (embed)
import qualified Data.Functor.Foldable.TH as TH import qualified Data.Functor.Foldable.TH as TH
import Data.Hashable import Database.Persist.Sql hiding (In, Statement)
import Data.Int import Dhall hiding (embed, maybe)
import qualified Data.Map as M import Dhall.TH
import qualified Data.Text as T import Language.Haskell.TH.Syntax (Lift)
import Data.Time import RIO
import qualified RIO.Map as M
import Database.Persist.Sql hiding (In, Statement) import qualified RIO.Text as T
import RIO.Time
import Dhall hiding (embed, maybe)
import Dhall.TH
import Language.Haskell.TH.Syntax (Lift)
import Text.Read
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | YAML CONFIG -- YAML CONFIG
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False }) makeHaskellTypesWith
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" (defaultGenerateOptions{generateToDhallInstance = False})
, MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit" [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
, MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday" , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
, MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat" , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
, MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat" , MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat"
, MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat" , MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat"
, MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD" , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate" , MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum" , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
, MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket" , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
, MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency" , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian" , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM" , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval" , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
, SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global" , SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global"
, SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat" , SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type" , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type" , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
, SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal" , SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
, SingleConstructor "TxOpts" "TxOpts" "(./dhall/Types.dhall).TxOpts.Type" , SingleConstructor "TxOpts" "TxOpts" "(./dhall/Types.dhall).TxOpts.Type"
, SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type" , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
, SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual" , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
, SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax" , SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax"
] ]
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | account tree -- account tree
data AccountTree = Placeholder T.Text T.Text [AccountTree] data AccountTree
| Account T.Text T.Text = Placeholder T.Text T.Text [AccountTree]
| Account T.Text T.Text
TH.makeBaseFunctor ''AccountTree TH.makeBaseFunctor ''AccountTree
@ -75,13 +70,13 @@ deriving instance Generic (AccountTreeF a)
deriving instance FromDhall a => FromDhall (AccountTreeF a) deriving instance FromDhall a => FromDhall (AccountTreeF a)
data AccountRoot_ a = AccountRoot_ data AccountRoot_ a = AccountRoot_
{ arAssets :: ![a] { arAssets :: ![a]
, arEquity :: ![a] , arEquity :: ![a]
, arExpenses :: ![a] , arExpenses :: ![a]
, arIncome :: ![a] , arIncome :: ![a]
, arLiabilities :: ![a] , arLiabilities :: ![a]
} }
deriving (Generic) deriving (Generic)
type AccountRootF = AccountRoot_ (Fix AccountTreeF) type AccountRootF = AccountRoot_ (Fix AccountTreeF)
@ -90,55 +85,58 @@ deriving instance FromDhall AccountRootF
type AccountRoot = AccountRoot_ AccountTree type AccountRoot = AccountRoot_ AccountTree
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | curencies -- curencies
deriving instance Eq Currency deriving instance Eq Currency
deriving instance Lift Currency deriving instance Lift Currency
deriving instance Hashable Currency deriving instance Hashable Currency
type CurID = T.Text type CurID = T.Text
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | DHALL CONFIG -- DHALL CONFIG
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
data Config_ a = Config_ data Config_ a = Config_
{ global :: !Global { global :: !Global
, budget :: !Budget , budget :: !Budget
, currencies :: ![Currency] , currencies :: ![Currency]
, statements :: ![Statement] , statements :: ![Statement]
, accounts :: !a , accounts :: !a
, sqlConfig :: !SqlConfig , sqlConfig :: !SqlConfig
} }
deriving (Generic) deriving (Generic)
type ConfigF = Config_ AccountRootF type ConfigF = Config_ AccountRootF
type Config = Config_ AccountRoot type Config = Config_ AccountRoot
unfix :: ConfigF -> Config unfix :: ConfigF -> Config
unfix c@Config_ { accounts = a } = c { accounts = a' } unfix c@Config_{accounts = a} = c{accounts = a'}
where where
a' = AccountRoot_ a' =
{ arAssets = unfixTree arAssets AccountRoot_
, arEquity = unfixTree arEquity { arAssets = unfixTree arAssets
, arExpenses = unfixTree arExpenses , arEquity = unfixTree arEquity
, arIncome = unfixTree arIncome , arExpenses = unfixTree arExpenses
, arLiabilities = unfixTree arLiabilities , arIncome = unfixTree arIncome
} , arLiabilities = unfixTree arLiabilities
}
unfixTree f = foldFix embed <$> f a unfixTree f = foldFix embed <$> f a
instance FromDhall a => FromDhall (Config_ a) instance FromDhall a => FromDhall (Config_ a)
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | accounts -- accounts
type AcntID = T.Text 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 Eq TimeUnit
deriving instance Hashable TimeUnit deriving instance Hashable TimeUnit
deriving instance Eq Weekday deriving instance Eq Weekday
@ -165,16 +163,17 @@ deriving instance Hashable GregorianM
-- Dhall.TH rearranges my fields :( -- Dhall.TH rearranges my fields :(
instance Ord Gregorian where instance Ord Gregorian where
compare compare
Gregorian { gYear = y, gMonth = m, gDay = d} Gregorian{gYear = y, gMonth = m, gDay = d}
Gregorian { gYear = y', gMonth = m', gDay = d'} = compare y y' Gregorian{gYear = y', gMonth = m', gDay = d'} =
<> compare m m' compare y y'
<> compare d d' <> compare m m'
<> compare d d'
instance Ord GregorianM where instance Ord GregorianM where
compare compare
GregorianM { gmYear = y, gmMonth = m} GregorianM{gmYear = y, gmMonth = m}
GregorianM { gmYear = y', gmMonth = m'} = compare y y' <> compare m m' GregorianM{gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
deriving instance Eq ModPat deriving instance Eq ModPat
deriving instance Hashable ModPat deriving instance Hashable ModPat
@ -186,99 +185,101 @@ deriving instance Eq DatePat
deriving instance Hashable DatePat deriving instance Hashable DatePat
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Budget (projecting into the future) -- Budget (projecting into the future)
data Income = Income data Income = Income
{ incGross :: !Decimal { incGross :: !Decimal
, incCurrency :: !CurID , incCurrency :: !CurID
, incWhen :: !DatePat , incWhen :: !DatePat
, incAccount :: !AcntID , incAccount :: !AcntID
, incPretax :: ![Allocation Decimal] , incPretax :: ![Allocation Decimal]
, incTaxes :: ![Tax] , incTaxes :: ![Tax]
, incPosttax :: ![Allocation (Maybe Decimal)] , incPosttax :: ![Allocation (Maybe Decimal)]
} }
deriving (Eq, Hashable, Generic, FromDhall) deriving (Eq, Hashable, Generic, FromDhall)
data Budget = Budget data Budget = Budget
{ income :: ![Income] { income :: ![Income]
, expenses :: ![Expense] , expenses :: ![Expense]
} }
deriving (Generic, FromDhall) deriving (Generic, FromDhall)
deriving instance Eq Tax deriving instance Eq Tax
deriving instance Hashable Tax deriving instance Hashable Tax
data Amount v = Amount data Amount v = Amount
{ amtValue :: !v { amtValue :: !v
, amtDesc :: !T.Text , amtDesc :: !T.Text
} deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall) }
deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall)
data Allocation v = Allocation data Allocation v = Allocation
{ alloPath :: !AcntID { alloPath :: !AcntID
, alloBucket :: !Bucket , alloBucket :: !Bucket
, alloAmts :: ![Amount v] , alloAmts :: ![Amount v]
, alloCurrency :: !CurID , alloCurrency :: !CurID
} }
deriving (Eq, Hashable, Generic, FromDhall) deriving (Eq, Hashable, Generic, FromDhall)
deriving instance Eq Bucket deriving instance Eq Bucket
deriving instance Hashable Bucket deriving instance Hashable Bucket
deriving instance Show Bucket deriving instance Show Bucket
data TimeAmount = TimeAmount data TimeAmount = TimeAmount
{ taWhen :: !DatePat { taWhen :: !DatePat
, taAmt :: Amount Decimal , taAmt :: Amount Decimal
} }
deriving (Eq, Hashable, Generic, FromDhall) deriving (Eq, Hashable, Generic, FromDhall)
data Expense = Expense data Expense = Expense
{ expFrom :: !AcntID { expFrom :: !AcntID
, expTo :: !AcntID , expTo :: !AcntID
, expBucket :: !Bucket , expBucket :: !Bucket
, expAmounts :: ![TimeAmount] , expAmounts :: ![TimeAmount]
, expCurrency :: !CurID , expCurrency :: !CurID
} }
deriving (Eq, Hashable, Generic, FromDhall) deriving (Eq, Hashable, Generic, FromDhall)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Statements (data from the past) -- Statements (data from the past)
data Statement = StmtManual Manual data Statement
| StmtImport Import = StmtManual Manual
deriving (Generic, FromDhall) | StmtImport Import
deriving (Generic, FromDhall)
deriving instance Hashable Manual deriving instance Hashable Manual
data Split a v c = Split data Split a v c = Split
{ sAcnt :: !a { sAcnt :: !a
, sValue :: !v , sValue :: !v
, sCurrency :: !c , sCurrency :: !c
, sComment :: !T.Text , sComment :: !T.Text
} }
deriving (Eq, Generic, Hashable, Show, FromDhall) deriving (Eq, Generic, Hashable, Show, FromDhall)
type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur
data Tx s = Tx data Tx s = Tx
{ txDescr :: !T.Text { txDescr :: !T.Text
, txDate :: !Day , txDate :: !Day
, txTags :: ![T.Text] , txTags :: ![T.Text]
, txSplits :: ![s] , txSplits :: ![s]
} }
deriving (Generic) deriving (Generic)
type ExpTx = Tx ExpSplit type ExpTx = Tx ExpSplit
instance FromDhall ExpTx where instance FromDhall ExpTx
data Import = Import data Import = Import
{ impPaths :: ![FilePath] { impPaths :: ![FilePath]
, impMatches :: ![Match] , impMatches :: ![Match]
, impDelim :: !Word , impDelim :: !Word
, impTxOpts :: !TxOpts , impTxOpts :: !TxOpts
, impSkipLines :: !Natural , impSkipLines :: !Natural
} }
deriving (Hashable, Generic, FromDhall) deriving (Hashable, Generic, FromDhall)
deriving instance Eq MatchVal deriving instance Eq MatchVal
deriving instance Hashable 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 -- TODO this just looks silly...but not sure how to simplify it
instance Ord MatchYMD where instance Ord MatchYMD where
compare (Y y) (Y y') = compare y y' compare (Y y) (Y y') = compare y y'
compare (YM g) (YM g') = compare g g' compare (YM g) (YM g') = compare g g'
compare (YMD g) (YMD 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) (YM g) = compare y (gmYear g) <> LT
compare (Y y) (YMD g) = compare y (gYear g) <> LT compare (Y y) (YMD g) = compare y (gYear g) <> LT
compare (YM g) (Y y') = compare (gmYear g) y' <> GT compare (YM g) (Y y') = compare (gmYear g) y' <> GT
compare (YMD g) (Y y') = compare (gYear g) y' <> GT compare (YMD g) (Y y') = compare (gYear g) y' <> GT
compare (YM g) (YMD g') = compare g (gregM g') <> LT compare (YM g) (YMD g') = compare g (gregM g') <> LT
compare (YMD g) (YM g') = compare (gregM g) g' <> GT compare (YMD g) (YM g') = compare (gregM g) g' <> GT
gregM :: Gregorian -> GregorianM gregM :: Gregorian -> GregorianM
gregM Gregorian { gYear = y, gMonth = m} gregM Gregorian{gYear = y, gMonth = m} =
= GregorianM { gmYear = y, gmMonth = m} GregorianM{gmYear = y, gmMonth = m}
instance Ord MatchDate where instance Ord MatchDate where
compare (On d) (On d') = compare d d' compare (On d) (On d') = compare d d'
compare (In d r) (In d' r') = compare d d' <> compare r r' compare (In d r) (In d' r') = compare d d' <> compare r r'
compare (On d) (In d' _) = compare d d' <> LT compare (On d) (In d' _) = compare d d' <> LT
compare (In d _) (On d') = compare d d' <> GT compare (In d _) (On d') = compare d d' <> GT
deriving instance Eq SplitNum deriving instance Eq SplitNum
deriving instance Hashable SplitNum deriving instance Hashable SplitNum
deriving instance Show SplitNum deriving instance Show SplitNum
-- | the value of a field in split (text version) {- | the value of a field in split (text version)
-- can either be a raw (constant) value, a lookup from the record, or a map can either be a raw (constant) value, a lookup from the record, or a map
-- between the lookup and some other value between the lookup and some other value
data SplitText t = ConstT !t -}
| LookupT !T.Text data SplitText t
| MapT (FieldMap T.Text t) = ConstT !t
| Map2T (FieldMap (T.Text, T.Text) t) | LookupT !T.Text
deriving (Eq, Generic, Hashable, Show, FromDhall) | MapT (FieldMap T.Text t)
| Map2T (FieldMap (T.Text, T.Text) t)
deriving (Eq, Generic, Hashable, Show, FromDhall)
type SplitCur = SplitText CurID type SplitCur = SplitText CurID
type SplitAcnt = SplitText AcntID type SplitAcnt = SplitText AcntID
data Field k v = Field data Field k v = Field
{ fKey :: !k { fKey :: !k
, fVal :: !v , fVal :: !v
} }
deriving (Show, Eq, Hashable, Generic, FromDhall) deriving (Show, Eq, Hashable, Generic, FromDhall)
type FieldMap k v = Field k (M.Map k v) type FieldMap k v = Field k (M.Map k v)
data MatchOther = Desc (Field T.Text T.Text) data MatchOther
| Val (Field T.Text MatchVal) = Desc (Field T.Text T.Text)
deriving (Show, Eq, Hashable, Generic, FromDhall) | Val (Field T.Text MatchVal)
deriving (Show, Eq, Hashable, Generic, FromDhall)
data ToTx = ToTx data ToTx = ToTx
{ ttCurrency :: !SplitCur { ttCurrency :: !SplitCur
, ttPath :: !SplitAcnt , ttPath :: !SplitAcnt
, ttSplit :: ![ExpSplit] , ttSplit :: ![ExpSplit]
} }
deriving (Eq, Generic, Hashable, Show, FromDhall) deriving (Eq, Generic, Hashable, Show, FromDhall)
data Match = Match data Match = Match
{ mDate :: Maybe MatchDate { mDate :: Maybe MatchDate
, mVal :: MatchVal , mVal :: MatchVal
, mDesc :: Maybe Text , mDesc :: Maybe Text
, mOther :: ![MatchOther] , mOther :: ![MatchOther]
, mTx :: Maybe ToTx , mTx :: Maybe ToTx
, mTimes :: Maybe Natural , mTimes :: Maybe Natural
, mPriority :: !Integer , mPriority :: !Integer
} }
deriving (Eq, Generic, Hashable, Show, FromDhall) deriving (Eq, Generic, Hashable, Show, FromDhall)
deriving instance Eq TxOpts deriving instance Eq TxOpts
deriving instance Hashable TxOpts deriving instance Hashable TxOpts
deriving instance Show TxOpts deriving instance Show TxOpts
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Specialized dhall types -- Specialized dhall types
deriving instance Eq Decimal deriving instance Eq Decimal
deriving instance Hashable Decimal deriving instance Hashable Decimal
deriving instance Show Decimal deriving instance Show Decimal
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | database cache types -- database cache types
data ConfigHashes = ConfigHashes data ConfigHashes = ConfigHashes
{ chIncome :: ![Int] { chIncome :: ![Int]
, chExpense :: ![Int] , chExpense :: ![Int]
, chManual :: ![Int] , chManual :: ![Int]
, chImport :: ![Int] , chImport :: ![Int]
} }
data ConfigType = CTIncome | CTExpense | CTManual | CTImport data ConfigType = CTIncome | CTExpense | CTManual | CTImport
deriving (Eq, Show, Read, Enum) deriving (Eq, Show, Read, Enum)
instance PersistFieldSql ConfigType where instance PersistFieldSql ConfigType where
sqlType _ = SqlString sqlType _ = SqlString
instance PersistField ConfigType where instance PersistField ConfigType where
toPersistValue = PersistText . T.pack . show toPersistValue = PersistText . T.pack . show
-- TODO these error messages *might* be good enough?
fromPersistValue (PersistText v) = -- TODO these error messages *might* be good enough?
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v fromPersistValue (PersistText v) =
fromPersistValue _ = Left "wrong type" maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "wrong type"
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | misc -- misc
data AcntType = AssetT data AcntType
| EquityT = AssetT
| ExpenseT | EquityT
| IncomeT | ExpenseT
| LiabilityT | IncomeT
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall) | LiabilityT
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
atName :: AcntType -> T.Text atName :: AcntType -> T.Text
atName AssetT = "asset" atName AssetT = "asset"
atName EquityT = "equity" atName EquityT = "equity"
atName ExpenseT = "expense" atName ExpenseT = "expense"
atName IncomeT = "income" atName IncomeT = "income"
atName LiabilityT = "liability" atName LiabilityT = "liability"
data AcntPath = AcntPath data AcntPath = AcntPath
{ apType :: !AcntType { apType :: !AcntType
, apChildren :: ![T.Text] , apChildren :: ![T.Text]
} deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall) }
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
data TxRecord = TxRecord data TxRecord = TxRecord
{ trDate :: !Day { trDate :: !Day
, trAmount :: !Rational , trAmount :: !Rational
, trDesc :: !T.Text , trDesc :: !T.Text
, trOther :: M.Map T.Text T.Text , trOther :: M.Map T.Text T.Text
} }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
type Bounds = (Day, Day) type Bounds = (Day, Day)
type MaybeBounds = (Maybe Day, Maybe Day) type MaybeBounds = (Maybe Day, Maybe Day)
data Keyed a = Keyed data Keyed a = Keyed
{ kKey :: !Int64 { kKey :: !Int64
, kVal :: !a , kVal :: !a
} }
deriving (Eq, Show, Functor) 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 data AcntSign = Credit | Debit
deriving (Show) deriving (Show)
sign2Int :: AcntSign -> Int sign2Int :: AcntSign -> Int
sign2Int Debit = 1 sign2Int Debit = 1
sign2Int Credit = 1 sign2Int Credit = 1
accountSign :: AcntType -> AcntSign accountSign :: AcntType -> AcntSign
accountSign AssetT = Debit accountSign AssetT = Debit
accountSign ExpenseT = Debit accountSign ExpenseT = Debit
accountSign IncomeT = Credit accountSign IncomeT = Credit
accountSign LiabilityT = Credit accountSign LiabilityT = Credit
accountSign EquityT = Credit accountSign EquityT = Credit
type RawAmount = Amount (Maybe Rational) type RawAmount = Amount (Maybe Rational)

182
lib/Internal/Utils.hs
View File

@ -1,23 +1,17 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Internal.Utils where module Internal.Utils where
import Data.Bifunctor import GHC.Real
import qualified Data.Map as M import Internal.Types
import Data.Ratio import RIO
import qualified Data.Text as T import qualified RIO.Map as M
import Data.Time import qualified RIO.Text as T
import qualified RIO.Text.Partial as TP
import GHC.Real import RIO.Time
import Text.Regex.TDFA
import Numeric.Natural
import Internal.Types
import Text.Read
import Text.Regex.TDFA
-- when bifunctor fails... -- when bifunctor fails...
thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f) 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 :: Gregorian -> (Integer, Int, Int)
gregTup g@Gregorian {..} gregTup g@Gregorian {..}
| gYear > 99 = error $ show g ++ ": year must only be two digits" | gYear > 99 = error $ show g ++ ": year must only be two digits"
| otherwise = ( fromIntegral gYear + 2000 | otherwise =
, fromIntegral gMonth ( fromIntegral gYear + 2000
, fromIntegral gDay) , fromIntegral gMonth
, fromIntegral gDay
)
gregMTup :: GregorianM -> (Integer, Int) gregMTup :: GregorianM -> (Integer, Int)
gregMTup g@GregorianM {..} gregMTup g@GregorianM {..}
| gmYear > 99 = error $ show g ++ ": year must only be two digits" | gmYear > 99 = error $ show g ++ ": year must only be two digits"
| otherwise = ( fromIntegral gmYear + 2000 | otherwise =
, fromIntegral gmMonth) ( fromIntegral gmYear + 2000
, fromIntegral gmMonth
)
data MDY_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int data MDY_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int
@ -43,21 +41,22 @@ fromMatchYMD m = case m of
Y y Y y
| y > 99 -> error $ show m ++ ": year must only be two digits" | y > 99 -> error $ show m ++ ": year must only be two digits"
| otherwise -> Y_ $ fromIntegral y + 2000 | otherwise -> Y_ $ fromIntegral y + 2000
YM g -> uncurry YM_ $ gregMTup g YM g -> uncurry YM_ $ gregMTup g
YMD g -> uncurry3 YMD_ $ gregTup g YMD g -> uncurry3 YMD_ $ gregTup g
compareDate :: MatchDate -> Day -> Ordering compareDate :: MatchDate -> Day -> Ordering
compareDate (On md) x = case fromMatchYMD md of compareDate (On md) x = case fromMatchYMD md of
Y_ y' -> compare y y' Y_ y' -> compare y y'
YM_ y' m' -> compare (y, m) (y', m') YM_ y' m' -> compare (y, m) (y', m')
YMD_ y' m' d' -> compare (y, m, d) (y', m', d') YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
where where
(y, m, d) = toGregorian x (y, m, d) = toGregorian x
compareDate (In md offset) x = case fromMatchYMD md of compareDate (In md offset) x = case fromMatchYMD md of
Y_ y' -> compareRange y' y Y_ y' -> compareRange y' y
YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
YMD_ y' m' d' -> let s = toModifiedJulianDay $ fromGregorian y' m' d' YMD_ y' m' d' ->
in compareRange s $ toModifiedJulianDay x let s = toModifiedJulianDay $ fromGregorian y' m' d'
in compareRange s $ toModifiedJulianDay x
where where
(y, m, _) = toGregorian x (y, m, _) = toGregorian x
compareRange start z compareRange start z
@ -69,37 +68,42 @@ dateMatches :: MatchDate -> Day -> Bool
dateMatches md = (EQ ==) . compareDate md dateMatches md = (EQ ==) . compareDate md
valMatches :: MatchVal -> Rational -> Bool valMatches :: MatchVal -> Rational -> Bool
valMatches MatchVal {..} x = checkMaybe (s ==) mvSign valMatches MatchVal {..} x =
&& checkMaybe (n ==) mvNum checkMaybe (s ==) mvSign
&& checkMaybe ((d * p ==) . fromIntegral) mvDen && checkMaybe (n ==) mvNum
&& checkMaybe ((d * p ==) . fromIntegral) mvDen
where where
(n, d) = properFraction $ abs x (n, d) = properFraction $ abs x
p = 10 ^ mvPrec p = 10 ^ mvPrec
s = signum x >= 0 s = signum x >= 0
evalSplit :: TxRecord -> ExpSplit -> RawSplit evalSplit :: TxRecord -> ExpSplit -> RawSplit
evalSplit r s@Split { sAcnt = a, sValue = v, sCurrency = c } = evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
s { sAcnt = evalAcnt r a s
{ sAcnt = evalAcnt r a
, sValue = evalExp r =<< v , sValue = evalExp r =<< v
, sCurrency = evalCurrency r c } , sCurrency = evalCurrency r c
}
evalAcnt :: TxRecord -> SplitAcnt -> T.Text evalAcnt :: TxRecord -> SplitAcnt -> T.Text
evalAcnt TxRecord { trOther = o } s = case s of evalAcnt TxRecord {trOther = o} s = case s of
ConstT p -> p 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 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 Map2T (Field (f1, f2) m) ->
k2 = lookupField f2 o let k1 = lookupField f1 o
in lookupErr "account key" (k1, k2) m k2 = lookupField f2 o
in lookupErr "account key" (k1, k2) m
evalCurrency :: TxRecord -> SplitCur -> T.Text evalCurrency :: TxRecord -> SplitCur -> T.Text
evalCurrency TxRecord { trOther = o } s = case s of evalCurrency TxRecord {trOther = o} s = case s of
ConstT p -> p 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 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 Map2T (Field (f1, f2) m) ->
k2 = lookupField f2 o let k1 = lookupField f1 o
in lookupErr "currency key" (k1, k2) m k2 = lookupField f2 o
in lookupErr "currency key" (k1, k2) m
errorT :: T.Text -> a errorT :: T.Text -> a
errorT = error . T.unpack 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 :: (Ord k, Show k) => T.Text -> k -> M.Map k v -> v
lookupErr what k m = case M.lookup k m of lookupErr what k m = case M.lookup k m of
Just x -> x 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 -> TxRecord -> Maybe (Maybe RawTx)
matches Match {..} r@TxRecord {..} matches Match {..} r@TxRecord {..}
| allPass = Just $ fmap eval mTx | allPass = Just $ fmap eval mTx
| otherwise = Nothing | otherwise = Nothing
where where
allPass = checkMaybe (`dateMatches` trDate) mDate allPass =
&& valMatches mVal trAmount checkMaybe (`dateMatches` trDate) mDate
&& checkMaybe (=~ trDesc) mDesc && valMatches mVal trAmount
&& all (fieldMatches trOther) mOther && checkMaybe (=~ trDesc) mDesc
&& all (fieldMatches trOther) mOther
eval (ToTx cur a ss) = toTx cur a ss r eval (ToTx cur a ss) = toTx cur a ss r
-- TODO these error messages are useless -- TODO these error messages are useless
fieldMatches :: M.Map T.Text T.Text -> MatchOther -> Bool fieldMatches :: M.Map T.Text T.Text -> MatchOther -> Bool
fieldMatches dict m = case m of 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 (Just v) -> valMatches mv v
_ -> error "you dummy" _ -> error "you dummy"
Desc (Field n md) -> case M.lookup n dict of Desc (Field n md) -> case M.lookup n dict of
(Just d) -> d =~ md (Just d) -> d =~ md
_ -> error "you dummy" _ -> error "you dummy"
checkMaybe :: (a -> Bool) -> Maybe a -> Bool checkMaybe :: (a -> Bool) -> Maybe a -> Bool
checkMaybe = maybe True checkMaybe = maybe True
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> RawTx toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> RawTx
toTx sc sa toSplits r@TxRecord {..} = toTx sc sa toSplits r@TxRecord {..} =
Tx { txTags = [] Tx
, txDate = trDate { txTags = []
, txDescr = trDesc , txDate = trDate
, txSplits = fromSplit:fmap (evalSplit r) toSplits , txDescr = trDesc
} , txSplits = fromSplit : fmap (evalSplit r) toSplits
}
where where
fromSplit = Split { sAcnt = evalAcnt r sa fromSplit =
, sCurrency = evalCurrency r sc Split
, sValue = Just trAmount { sAcnt = evalAcnt r sa
, sComment = "" , sCurrency = evalCurrency r sc
} , sValue = Just trAmount
, sComment = ""
}
parseRational :: MonadFail m => T.Text -> T.Text -> m Rational parseRational :: MonadFail m => T.Text -> T.Text -> m Rational
parseRational pat s = case ms of parseRational pat s = case ms of
@ -158,16 +166,22 @@ parseRational pat s = case ms of
let p = 10 ^ T.length y let p = 10 ^ T.length y
(k, w) <- readWhole sign x (k, w) <- readWhole sign x
return $ k * (w + d % p) return $ k * (w + d % p)
_ -> msg "malformed decimal" _ -> msg "malformed decimal"
where where
(_, _, _, ms) = (s =~ pat) :: (T.Text, T.Text, T.Text, [T.Text]) (_, _, _, ms) = (s =~ pat) :: (T.Text, T.Text, T.Text, [T.Text])
readT what t = case readMaybe $ T.unpack t of readT what t = case readMaybe $ T.unpack t of
Just d -> return $ fromInteger d Just d -> return $ fromInteger d
_ -> msg $ T.unwords ["could not parse", what, t] _ -> msg $ T.unwords ["could not parse", what, t]
msg m = fail $ T.unpack $ T.concat [ m msg m =
, "; pattern = ", pat fail $
, "; query = ", s T.unpack $
] T.concat
[ m
, "; pattern = "
, pat
, "; query = "
, s
]
readSign x readSign x
| x == "-" = return (-1) | x == "-" = return (-1)
| x == "+" || x == "" = return 1 | x == "+" || x == "" = return 1
@ -177,23 +191,25 @@ parseRational pat s = case ms of
k <- readSign sign k <- readSign sign
return (k, w) return (k, w)
-- TODO don't use a partial function
readRational :: MonadFail m => T.Text -> m Rational 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] -> return $ fromInteger $ readT x
[x, y] -> let x' = readT x [x, y] ->
y' = readT y let x' = readT x
p = 10 ^ T.length y y' = readT y
k = if x' >= 0 then 1 else -1 in p = 10 ^ T.length y
if y' > p k = if x' >= 0 then 1 else -1
then fail "not enough precision to parse" in if y' > p
else return $ fromInteger x' + k * y' % p then fail "not enough precision to parse"
else return $ fromInteger x' + k * y' % p
_ -> fail $ T.unpack $ T.append "malformed decimal: " s _ -> fail $ T.unpack $ T.append "malformed decimal: " s
where where
readT = read . T.unpack readT = read . T.unpack
-- TODO smells like a lens -- TODO smells like a lens
mapTxSplits :: (a -> b) -> Tx a -> Tx b 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 :: (Gregorian, Gregorian) -> Bounds
boundsFromGregorian = bimap fromGregorian' fromGregorian' boundsFromGregorian = bimap fromGregorian' fromGregorian'
@ -208,7 +224,7 @@ inMaybeBounds :: MaybeBounds -> Day -> Bool
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1 inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
intervalMaybeBounds :: Interval -> MaybeBounds intervalMaybeBounds :: Interval -> MaybeBounds
intervalMaybeBounds Interval { intStart = s, intEnd = e } = intervalMaybeBounds Interval {intStart = s, intEnd = e} =
(fromGregorian' <$> s, fromGregorian' <$> e) (fromGregorian' <$> s, fromGregorian' <$> e)
resolveBounds :: MaybeBounds -> IO Bounds 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'] fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
where where
s = if x >= 0 then "" else "-" s = if x >= 0 then "" else "-"
x'@(n:%d) = abs x x'@(n :% d) = abs x
p = 10 ^ precision p = 10 ^ precision
n' = toInteger $ div n d n' = div n d
d' = toInteger $ (\(a:%b) -> div a b) ((x' - fromIntegral n') * p) d' = (\(a :% b) -> div a b) ((x' - fromIntegral n') * p)
txt = T.pack . show txt = T.pack . show
pad i c z = T.append (T.replicate (i - T.length z) c) z 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 :: TxRecord -> SplitNum -> Maybe Rational
evalExp r s = case s of evalExp r s = case s of
(LookupN t) -> readRational =<< M.lookup t (trOther r) (LookupN t) -> readRational =<< M.lookup t (trOther r)
(ConstN c) -> Just $ dec2Rat c (ConstN c) -> Just $ dec2Rat c
AmountN -> Just $ trAmount r AmountN -> Just $ trAmount r
dec2Rat :: Decimal -> Rational dec2Rat :: Decimal -> Rational
dec2Rat D {..} = dec2Rat D {..} =

33
package.yaml
View File

@ -21,7 +21,7 @@ description: Please see the README on GitHub at <https://github.com/ndwa
dependencies: dependencies:
- base >= 4.12 && < 10 - base >= 4.12 && < 10
# - rio >= 0.1.22.0 - rio >= 0.1.21.0
- persistent >= 2.13.3.1 - persistent >= 2.13.3.1
- persistent-sqlite >= 2.13.1.0 - persistent-sqlite >= 2.13.1.0
- monad-logger >= 0.3.36 - monad-logger >= 0.3.36
@ -33,15 +33,10 @@ dependencies:
- containers >= 0.6.4.1 - containers >= 0.6.4.1
- ghc >= 9.0.2 - ghc >= 9.0.2
- cassava - cassava
- bytestring
- vector
- regex-tdfa - regex-tdfa
- utf8-string
- transformers
- esqueleto - esqueleto
- template-haskell - template-haskell
- hashable - hashable
- yaml
- optparse-applicative - optparse-applicative
- recursion-schemes - recursion-schemes
- data-fix - data-fix
@ -51,17 +46,14 @@ library:
source-dirs: lib/ source-dirs: lib/
ghc-options: ghc-options:
- -Wall - -Wall
- -Werror - -Wcompat
- -threaded - -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wpartial-fields - -Wpartial-fields
exposed-modules: - -Werror
- Internal.Config - -O2
- Internal.Types
- Internal.Utils
- Internal.Database.Ops
- Internal.Database.Model
- Internal.Insert
- Internal.Statement
executables: executables:
pwncash: pwncash:
@ -69,9 +61,14 @@ executables:
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall - -Wall
- -Werror - -Wcompat
- -threaded - -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wpartial-fields - -Wpartial-fields
- -Werror
- -O2 - -O2
- -threaded
dependencies: dependencies:
- budget - budget