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