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

24
budget.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.35.0.
-- This file has been generated from package.yaml by hpack version 0.35.1.
--
-- see: https://github.com/sol/hpack
@ -26,20 +26,19 @@ source-repository head
library
exposed-modules:
Internal.Config
Internal.Types
Internal.Utils
Internal.Database.Ops
Internal.Database.Model
Internal.Database.Ops
Internal.Insert
Internal.Statement
Internal.Types
Internal.Utils
other-modules:
Paths_budget
hs-source-dirs:
lib/
ghc-options: -Wall -Werror -threaded -Wpartial-fields
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
build-depends:
base >=4.12 && <10
, bytestring
, cassava
, conduit >=1.3.4.2
, containers >=0.6.4.1
@ -56,13 +55,10 @@ library
, persistent-sqlite >=2.13.1.0
, recursion-schemes
, regex-tdfa
, rio >=0.1.21.0
, template-haskell
, text >=1.2.5.0
, time >=1.9.3
, transformers
, utf8-string
, vector
, yaml
default-language: Haskell2010
executable pwncash
@ -71,11 +67,10 @@ executable pwncash
Paths_budget
hs-source-dirs:
app
ghc-options: -Wall -Werror -threaded -Wpartial-fields -O2
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
build-depends:
base >=4.12 && <10
, budget
, bytestring
, cassava
, conduit >=1.3.4.2
, containers >=0.6.4.1
@ -92,11 +87,8 @@ executable pwncash
, persistent-sqlite >=2.13.1.0
, recursion-schemes
, regex-tdfa
, rio >=0.1.21.0
, template-haskell
, text >=1.2.5.0
, time >=1.9.3
, transformers
, utf8-string
, vector
, yaml
default-language: Haskell2010

81
lib/Internal/Config.hs
View File

@ -1,76 +1,21 @@
module Internal.Config
( readConfig
, readYaml
) where
-- , readYaml
)
where
import Control.Exception
-- import Control.Lens
-- import Data.Maybe
-- import qualified Data.Text as T
-- import Data.Typeable
-- import Data.Void
import Data.Yaml
import Dhall hiding (record)
-- import qualified Dhall.Core as DC
-- import qualified Dhall.Map as DM
-- import Dhall.Src
import Internal.Types
-- import Control.Exception
-- import Data.Yaml
import Dhall hiding (record)
import Internal.Types
readConfig :: FilePath -> IO Config
readConfig confpath = do
-- let subs = DM.fromList typeSubs
-- let settings = over substitutions (DM.union subs) defaultEvaluateSettings
-- unfix <$> inputFileWithSettings settings auto confpath
unfix <$> inputFile auto confpath
-- typeSubs :: [(T.Text, DC.Expr Src Void)]
-- typeSubs = firstOrder ++ higherOrder
-- where
-- toVar a = fmap (\n -> (T.pack $ show n, maximum $ expected a))
-- $ listToMaybe $ snd $ splitTyConApp $ typeOf a
-- higherOrder =
-- [ ("ExpSplit", maximum $ expected (auto :: Decoder ExpSplit))
-- , ("ExpTx", maximum $ expected (auto :: Decoder ExpTx))
-- , ("SplitCur", maximum $ expected (auto :: Decoder SplitCur))
-- , ("SplitAcnt", maximum $ expected (auto :: Decoder SplitAcnt))
-- , ("CurID", maximum $ expected (auto :: Decoder CurID))
-- , ("AcntID", maximum $ expected (auto :: Decoder AcntID))
-- ]
-- firstOrder = catMaybes
-- [ toVar (auto :: Decoder TimeUnit)
-- , toVar (auto :: Decoder WeekdayPat)
-- , toVar (auto :: Decoder MDYPat)
-- , toVar (auto :: Decoder Gregorian)
-- , toVar (auto :: Decoder GregorianM)
-- , toVar (auto :: Decoder ModPat)
-- , toVar (auto :: Decoder CronPat)
-- , toVar (auto :: Decoder DatePat)
-- , toVar (auto :: Decoder Income)
-- , toVar (auto :: Decoder Tax)
-- , toVar (auto :: Decoder Bucket)
-- , toVar (auto :: Decoder TimeAmount)
-- , toVar (auto :: Decoder Expense)
-- , toVar (auto :: Decoder Decimal)
-- , toVar (auto :: Decoder Statement)
-- , toVar (auto :: Decoder Manual)
-- , toVar (auto :: Decoder TxOpts)
-- , toVar (auto :: Decoder ToTx)
-- , toVar (auto :: Decoder Match)
-- , toVar (auto :: Decoder MatchYMD)
-- , toVar (auto :: Decoder MatchVal)
-- , toVar (auto :: Decoder MatchDate)
-- , toVar (auto :: Decoder SplitNum)
-- , toVar (auto :: Decoder MatchDesc)
-- , toVar (auto :: Decoder MatchOther)
-- , toVar (auto :: Decoder SqlConfig)
-- ]
readYaml :: FromJSON a => FilePath -> IO a
readYaml p = do
r <- decodeFileEither p
case r of
Right a -> return a
Left e -> throw e
-- readYaml :: FromJSON a => FilePath -> IO a
-- readYaml p = do
-- r <- decodeFileEither p
-- case r of
-- Right a -> return a
-- Left e -> throw e

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

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

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

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

378
lib/Internal/Insert.hs
View File

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

262
lib/Internal/Statement.hs
View File

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

488
lib/Internal/Types.hs
View File

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

182
lib/Internal/Utils.hs
View File

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

33
package.yaml
View File

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