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

57
app/Main.hs
View File

@ -2,24 +2,22 @@
module Main (main) where module Main (main) where
import qualified Data.Text as T
import Internal.Config import Internal.Config
import Internal.Database.Ops import Internal.Database.Ops
import Internal.Insert import Internal.Insert
import Internal.Types import Internal.Types
import Internal.Utils import Internal.Utils
import Control.Monad.Trans.Reader
import Options.Applicative import Options.Applicative
import RIO
import System.FilePath import RIO.FilePath
import qualified RIO.Text as T
main :: IO () main :: IO ()
main = parse =<< execParser o main = parse =<< execParser o
where where
o = info (options <**> helper) o =
info
(options <**> helper)
( fullDesc ( fullDesc
<> progDesc "Pwn your budget" <> progDesc "Pwn your budget"
<> header "pwncash - your budget, your life" <> header "pwncash - your budget, your life"
@ -27,14 +25,16 @@ main = parse =<< execParser o
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 =
strOption
( long "config" ( long "config"
<> short 'c' <> short 'c'
<> metavar "CONFIG" <> metavar "CONFIG"
@ -43,7 +43,8 @@ configFile = strOption
) )
options :: Parser Options options :: Parser Options
options = getConf reset options =
getConf reset
<|> getConf dumpCurrencies <|> getConf dumpCurrencies
<|> getConf dumpAccounts <|> getConf dumpAccounts
<|> getConf dumpAccountKeys <|> getConf dumpAccountKeys
@ -52,21 +53,27 @@ options = getConf reset
getConf m = Options <$> configFile <*> m getConf m = Options <$> configFile <*> m
reset :: Parser Mode reset :: Parser Mode
reset = flag' Reset reset =
flag'
Reset
( long "reset" ( long "reset"
<> short 'R' <> short 'R'
<> help "Reset the database" <> help "Reset the database"
) )
dumpCurrencies :: Parser Mode dumpCurrencies :: Parser Mode
dumpCurrencies = flag' DumpCurrencies dumpCurrencies =
flag'
DumpCurrencies
( long "currencies" ( long "currencies"
<> short 'C' <> short 'C'
<> help "Dump all currencies in the configuration" <> help "Dump all currencies in the configuration"
) )
dumpAccounts :: Parser Mode dumpAccounts :: Parser Mode
dumpAccounts = flag' DumpAccounts dumpAccounts =
flag'
DumpAccounts
( long "accounts" ( long "accounts"
<> short 'A' <> short 'A'
<> help "Dump all accounts in the configuration" <> help "Dump all accounts in the configuration"
@ -74,14 +81,18 @@ dumpAccounts = flag' DumpAccounts
-- 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 =
flag'
DumpAccountKeys
( long "account_keys" ( long "account_keys"
<> short 'K' <> short 'K'
<> help "Dump all account keys/aliases" <> help "Dump all account keys/aliases"
) )
sync :: Parser Mode sync :: Parser Mode
sync = flag' Sync sync =
flag'
Sync
( long "sync" ( long "sync"
<> short 'S' <> short 'S'
<> help "Sync config to database" <> help "Sync config to database"
@ -101,7 +112,7 @@ 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,7 +120,8 @@ 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 =
[ ("Assets", arAssets)
, ("Equity", arEquity) , ("Equity", arEquity)
, ("Expenses", arExpenses) , ("Expenses", arExpenses)
, ("Income", arIncome) , ("Income", arIncome)
@ -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

77
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.Lens
-- import Data.Maybe
-- import qualified Data.Text as T
-- import Data.Typeable
-- import Data.Void
import Data.Yaml
-- import Control.Exception
-- import Data.Yaml
import Dhall hiding (record) import Dhall hiding (record)
-- import qualified Dhall.Core as DC
-- import qualified Dhall.Map as DM
-- import Dhall.Src
import Internal.Types 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

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

@ -17,18 +17,17 @@
module Internal.Database.Model where module Internal.Database.Model where
import Control.Monad.Trans.Reader
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Time
import Database.Esqueleto.Experimental import Database.Esqueleto.Experimental
import Database.Persist.TH import Database.Persist.TH
import Internal.Types import Internal.Types
import RIO
import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| share
[mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase|
CommitR sql=commits CommitR sql=commits
hash Int hash Int
type ConfigType type ConfigType

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

@ -14,34 +14,32 @@ module Internal.Database.Ops
, tree2Records , tree2Records
, flattenAcntRoot , flattenAcntRoot
, paths2IDs , paths2IDs
)
) where where
import Control.Monad.Logger
import Control.Monad.Trans.Reader
import Conduit import Conduit
import Control.Monad.Logger
import Data.Bifunctor
import Data.Either
import Data.Hashable 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.Esqueleto.Experimental
import Database.Persist.Sql hiding (delete, (==.), (||.)) import Database.Persist.Sql hiding (delete, (==.), (||.))
import Database.Persist.Sqlite hiding (delete, (==.), (||.)) import Database.Persist.Sqlite hiding (delete, (==.), (||.))
import Database.Sqlite hiding (Config) import Database.Sqlite hiding (Config)
import Internal.Database.Model import Internal.Database.Model
import Internal.Types import Internal.Types
import Internal.Utils 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_ :: SqlConfig -> SqlPersistT (ResourceT (NoLoggingT IO)) () -> IO ()
migrate_ c more = runNoLoggingT $ runResourceT migrate_ c more =
$ withSqlConn (openConnection c) (\backend -> runNoLoggingT $
runResourceT $
withSqlConn
(openConnection c)
( \backend ->
flip runSqlConn backend $ do flip runSqlConn backend $ do
runMigration migrateAll runMigration migrateAll
more more
@ -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
$ table @AccountR
`innerJoin` table @SplitR `innerJoin` table @SplitR
`on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount) `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount)
`innerJoin` table @TransactionR `innerJoin` table @TransactionR
`on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId) `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 ^. AccountRFullpath
, accounts ^. AccountRName , accounts ^. AccountRName
, sum_ $ splits ^. SplitRValue) , 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,8 +93,11 @@ 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_
{ budget = Budget {expenses = xs, income = is}
, statements = ss
} =
(hash <$> xs) ++ (hash <$> is) ++ (hash <$> ms) ++ (hash <$> ps) (hash <$> xs) ++ (hash <$> is) ++ (hash <$> ms) ++ (hash <$> ps)
where where
(ms, ps) = partitionEithers $ fmap go ss (ms, ps) = partitionEithers $ fmap go ss
@ -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,39 +198,42 @@ 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 let e = tree2Entity t (fmap snd ps) n d
e = tree2Entity t (fmap snd ps) n d
k = entityKey e k = entityKey e
(as, aps, ms) = unzip3 $ fmap (go ((k, n):ps)) cs (as, aps, ms) = unzip3 $ fmap (go ((k, n) : ps)) cs
a0 = acnt k n (fmap snd ps) d a0 = acnt k n (fmap snd ps) d
paths = expand k $ fmap fst ps paths = expand k $ fmap fst ps
in (a0:concat as, paths ++ concat aps, concat ms) in (a0 : concat as, paths ++ concat aps, concat ms)
go ps (Account d n) = 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] in ( [acnt k n (fmap snd ps) d]
, expand k $ fmap fst ps , expand k $ fmap fst ps
, [(AcntPath t $ reverse $ n:fmap snd ps, (k, sign))] , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign))]
) )
toPath = T.intercalate "/" . (atName t:) . reverse 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 =
uncurry zip
. first trimNames . first trimNames
. unzip . unzip
. L.sortOn fst . L.sortOn fst
@ -237,22 +247,22 @@ 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
@ -261,9 +271,15 @@ trimNames = fmap fmt . trimAll 0
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 =
foldr
( \x r k -> case k of
0 -> Just x 0 -> Just x
_ -> r (k-1)) (const Nothing) xs n _ -> r (k - 1)
)
(const Nothing)
xs
n
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)] flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
flattenAcntRoot AccountRoot_ {..} = flattenAcntRoot AccountRoot_ {..} =
@ -289,7 +305,8 @@ 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 ->
DBState
{ kmCurrency = cm { kmCurrency = cm
, kmAccount = am , kmAccount = am
, kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c , kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c

180
lib/Internal/Insert.hs
View File

@ -5,35 +5,28 @@
module Internal.Insert module Internal.Insert
( insertStatements ( insertStatements
, insertBudget , insertBudget
) where )
where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.Either
import Data.Hashable 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.Class
import Database.Persist.Sql hiding (Single, Statement) import Database.Persist.Sql hiding (Single, Statement)
import Internal.Database.Model import Internal.Database.Model
import Internal.Statement import Internal.Statement
import Internal.Types hiding (sign) import Internal.Types hiding (sign)
import Internal.Utils import Internal.Utils
import RIO hiding (to)
import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time
import Numeric.Natural lookupKey :: (Ord k, Show k, MonadIO m) => M.Map k v -> k -> m (Maybe v)
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,18 +49,21 @@ 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
ModPat
{ mpStart = s
, mpBy = b , mpBy = b
, mpUnit = u , mpUnit = u
, mpRepeats = r , mpRepeats = r
} (lower, upper) = }
takeWhile (<= upper) (lower, upper) =
$ (`addFun` start) . (* b') takeWhile (<= upper) $
<$> maybe id (take . fromIntegral) r [0..] (`addFun` start) . (* b')
<$> maybe id (take . fromIntegral) r [0 ..]
where where
start = maybe lower fromGregorian' s start = maybe lower fromGregorian' s
b' = fromIntegral b b' = fromIntegral b
@ -80,11 +76,14 @@ expandModPat ModPat { mpStart = s
-- 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
CronPat
{ cronWeekly = w
, cronYear = y , cronYear = y
, cronMonth = m , cronMonth = m
, cronDay = d , cronDay = d
} x = }
x =
yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w
where where
testMaybe = maybe True testMaybe = maybe True
@ -112,9 +111,9 @@ 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,7 +141,9 @@ 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
i@Income
{ incCurrency = cur
, incWhen = dp , incWhen = dp
, incAccount = from , incAccount = from
, incTaxes = ts , incTaxes = ts
@ -149,11 +155,13 @@ insertIncome i@Income { incCurrency = cur
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
forM_ (expandDatePat bounds dp) $ \day -> do forM_ (expandDatePat bounds dp) $ \day -> do
alloTx <- concat <$> mapM (allocationToTx from day) as alloTx <- concat <$> mapM (allocationToTx from day) as
taxTx <- fmap (, Fixed) <$> mapM (taxToTx from day cur) ts taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx 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
Income
{ incGross = g
, incPretax = pre , incPretax = pre
, incTaxes = tax , incTaxes = tax
, incPosttax = post , incPosttax = post
@ -164,7 +172,7 @@ balanceIncome Income { incGross = g
bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax) 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,44 +185,60 @@ 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
from
day
Allocation
{ alloPath = to
, alloBucket = b , alloBucket = b
, alloCurrency = cur , alloCurrency = cur
, alloAmts = as , alloAmts = as
} = } =
fmap (, b) <$> mapM (transferToTx day from to cur) 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
e@Expense
{ expFrom = from
, expTo = to , expTo = to
, expCurrency = cur , expCurrency = cur
, expBucket = buc , expBucket = buc
@ -224,12 +248,25 @@ insertExpense e@Expense { expFrom = from
ts <- concat <$> mapM (timeAmountToTx from to cur) as ts <- concat <$> mapM (timeAmountToTx from to cur) as
lift $ mapM_ (insertTxBucket (Just buc) c) ts 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
to
cur
TimeAmount
{ taWhen = dp
, taAmt =
Amount
{ amtValue = v
, amtDesc = d , amtDesc = d
} } = do }
} = do
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
mapM tx $ expandDatePat bounds dp mapM tx $ expandDatePat bounds dp
where where
@ -246,7 +283,9 @@ 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
m@Manual
{ manualDate = dp
, manualFrom = from , manualFrom = from
, manualTo = to , manualTo = to
, manualValue = v , manualValue = v
@ -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 =
Tx
{ txDescr = desc
, txDate = day , txDate = day
, txTags = [] , txTags = []
, txSplits = [split from (-val), split to val] , 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 $
s
{ sAcnt = aid'
, sCurrency = cid' , sCurrency = cid'
, sValue = v * fromIntegral (sign2Int sign') , 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

150
lib/Internal/Statement.hs
View File

@ -3,38 +3,29 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module Internal.Statement module Internal.Statement (
( readImport readImport,
) where ) 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.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.Database.Model
import Internal.Types import Internal.Types
import Internal.Utils import Internal.Utils
import RIO
import Numeric.Natural import qualified RIO.ByteString.Lazy as BL
import RIO.FilePath
import System.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?) -- 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
Import
{ impPaths = ps
, impMatches = ms , impMatches = ms
, impTxOpts = ns , impTxOpts = ns
, impDelim = d , impDelim = d
@ -46,8 +37,13 @@ readImport Import { impPaths = ps
liftIO $ mapM_ print notfound liftIO $ mapM_ print notfound
return ts 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
@ -55,50 +51,55 @@ readImport_ n delim tns p = do
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 =
( catMaybes ts
, T.unpack <$> (es ++ bu) , T.unpack <$> (es ++ bu)
-- TODO record number of times each match hits for debugging , -- TODO record number of times each match hits for debugging
, notfound 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 =
fmap matchToGroup
. L.groupBy (\a b -> mPriority a == mPriority b) . L.groupBy (\a b -> mPriority a == mPriority b)
. L.sortOn (Down . mPriority) . 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
@ -157,12 +159,13 @@ matchAll = go ([], [])
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,13 +174,13 @@ 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
@ -185,32 +188,33 @@ 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 =
fmap concat
<$> mapM (uncurry bal) <$> mapM (uncurry bal)
$ groupByKey $ groupByKey
$ fmap (\s -> (sCurrency s, s)) ss $ 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 (: []))

94
lib/Internal/Types.hs
View File

@ -17,26 +17,21 @@ 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 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 Database.Persist.Sql hiding (In, Statement)
import Dhall hiding (embed, maybe) import Dhall hiding (embed, maybe)
import Dhall.TH import Dhall.TH
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
import RIO
import Text.Read import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | YAML CONFIG -- YAML CONFIG
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False }) makeHaskellTypesWith
(defaultGenerateOptions{generateToDhallInstance = False})
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
, MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit" , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
, MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday" , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
@ -47,7 +42,6 @@ makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False }
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate" , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum" , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
, MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket" , 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"
@ -64,9 +58,10 @@ makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False }
] ]
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | account tree -- account tree
data AccountTree = Placeholder T.Text T.Text [AccountTree] data AccountTree
= Placeholder T.Text T.Text [AccountTree]
| Account T.Text T.Text | Account T.Text T.Text
TH.makeBaseFunctor ''AccountTree TH.makeBaseFunctor ''AccountTree
@ -90,16 +85,17 @@ 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_
@ -117,9 +113,10 @@ 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' =
AccountRoot_
{ arAssets = unfixTree arAssets { arAssets = unfixTree arAssets
, arEquity = unfixTree arEquity , arEquity = unfixTree arEquity
, arExpenses = unfixTree arExpenses , arExpenses = unfixTree arExpenses
@ -131,14 +128,15 @@ unfix c@Config_ { accounts = a } = c { accounts = 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
@ -166,15 +164,16 @@ 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 y y'
<> compare m m' <> compare m m'
<> compare d d' <> 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,7 +185,7 @@ 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
@ -211,7 +210,8 @@ 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
@ -241,9 +241,10 @@ data Expense = Expense
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
= StmtManual Manual
| StmtImport Import | StmtImport Import
deriving (Generic, FromDhall) deriving (Generic, FromDhall)
@ -269,7 +270,7 @@ data Tx s = Tx
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]
@ -305,8 +306,8 @@ instance Ord MatchYMD where
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'
@ -318,10 +319,12 @@ 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 -}
data SplitText t
= ConstT !t
| LookupT !T.Text | LookupT !T.Text
| MapT (FieldMap T.Text t) | MapT (FieldMap T.Text t)
| Map2T (FieldMap (T.Text, T.Text) t) | Map2T (FieldMap (T.Text, T.Text) t)
@ -339,7 +342,8 @@ data Field k v = Field
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
= Desc (Field T.Text T.Text)
| Val (Field T.Text MatchVal) | Val (Field T.Text MatchVal)
deriving (Show, Eq, Hashable, Generic, FromDhall) deriving (Show, Eq, Hashable, Generic, FromDhall)
@ -366,14 +370,15 @@ 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]
@ -390,15 +395,17 @@ instance PersistFieldSql ConfigType where
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? -- TODO these error messages *might* be good enough?
fromPersistValue (PersistText v) = fromPersistValue (PersistText v) =
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "wrong type" fromPersistValue _ = Left "wrong type"
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | misc -- misc
data AcntType = AssetT data AcntType
= AssetT
| EquityT | EquityT
| ExpenseT | ExpenseT
| IncomeT | IncomeT
@ -415,7 +422,8 @@ 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
@ -435,7 +443,7 @@ data Keyed a = Keyed
} }
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)

96
lib/Internal/Utils.hs
View File

@ -4,19 +4,13 @@
module Internal.Utils where 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 GHC.Real
import Numeric.Natural
import Internal.Types import Internal.Types
import RIO
import Text.Read 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 import Text.Regex.TDFA
-- when bifunctor fails... -- when bifunctor fails...
@ -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 gYear + 2000
, fromIntegral gMonth , fromIntegral gMonth
, fromIntegral gDay) , 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
@ -56,7 +54,8 @@ compareDate (On md) x = case fromMatchYMD md of
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' ->
let s = toModifiedJulianDay $ fromGregorian y' m' d'
in compareRange s $ toModifiedJulianDay x in compareRange s $ toModifiedJulianDay x
where where
(y, m, _) = toGregorian x (y, m, _) = toGregorian x
@ -69,7 +68,8 @@ 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 (s ==) mvSign
&& checkMaybe (n ==) mvNum && checkMaybe (n ==) mvNum
&& checkMaybe ((d * p ==) . fromIntegral) mvDen && checkMaybe ((d * p ==) . fromIntegral) mvDen
where where
@ -78,26 +78,30 @@ valMatches MatchVal {..} x = checkMaybe (s ==) mvSign
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) ->
let k1 = lookupField f1 o
k2 = lookupField f2 o k2 = lookupField f2 o
in lookupErr "account key" (k1, k2) m 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) ->
let k1 = lookupField f1 o
k2 = lookupField f2 o k2 = lookupField f2 o
in lookupErr "currency key" (k1, k2) m in lookupErr "currency key" (k1, k2) m
@ -117,7 +121,8 @@ 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 =
checkMaybe (`dateMatches` trDate) mDate
&& valMatches mVal trAmount && valMatches mVal trAmount
&& checkMaybe (=~ trDesc) mDesc && checkMaybe (=~ trDesc) mDesc
&& all (fieldMatches trOther) mOther && all (fieldMatches trOther) mOther
@ -138,13 +143,16 @@ 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
{ txTags = []
, txDate = trDate , txDate = trDate
, txDescr = trDesc , txDescr = trDesc
, txSplits = fromSplit:fmap (evalSplit r) toSplits , txSplits = fromSplit : fmap (evalSplit r) toSplits
} }
where where
fromSplit = Split { sAcnt = evalAcnt r sa fromSplit =
Split
{ sAcnt = evalAcnt r sa
, sCurrency = evalCurrency r sc , sCurrency = evalCurrency r sc
, sValue = Just trAmount , sValue = Just trAmount
, sComment = "" , sComment = ""
@ -164,9 +172,15 @@ parseRational pat s = case ms of
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)
@ -177,14 +191,16 @@ 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] ->
let x' = readT x
y' = readT y y' = readT y
p = 10 ^ T.length y p = 10 ^ T.length y
k = if x' >= 0 then 1 else -1 in k = if x' >= 0 then 1 else -1
if y' > p in if y' > p
then fail "not enough precision to parse" then fail "not enough precision to parse"
else return $ fromInteger x' + k * y' % p else return $ fromInteger x' + k * y' % p
_ -> fail $ T.unpack $ T.append "malformed decimal: " s _ -> fail $ T.unpack $ T.append "malformed decimal: " s
@ -193,7 +209,7 @@ readRational s = case T.splitOn "." s of
-- 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

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