ENH use rio modules everywhere and use recommended flags
This commit is contained in:
parent
c5e32aee48
commit
20cc4db986
55
app/Main.hs
55
app/Main.hs
|
|
@ -2,24 +2,22 @@
|
|||
|
||||
module Main (main) where
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Internal.Config
|
||||
import Internal.Database.Ops
|
||||
import Internal.Insert
|
||||
import Internal.Types
|
||||
import Internal.Utils
|
||||
|
||||
import Control.Monad.Trans.Reader
|
||||
|
||||
import Options.Applicative
|
||||
|
||||
import System.FilePath
|
||||
import RIO
|
||||
import RIO.FilePath
|
||||
import qualified RIO.Text as T
|
||||
|
||||
main :: IO ()
|
||||
main = parse =<< execParser o
|
||||
where
|
||||
o = info (options <**> helper)
|
||||
o =
|
||||
info
|
||||
(options <**> helper)
|
||||
( fullDesc
|
||||
<> progDesc "Pwn your budget"
|
||||
<> header "pwncash - your budget, your life"
|
||||
|
|
@ -27,14 +25,16 @@ main = parse =<< execParser o
|
|||
|
||||
data Options = Options FilePath Mode
|
||||
|
||||
data Mode = Reset
|
||||
data Mode
|
||||
= Reset
|
||||
| DumpCurrencies
|
||||
| DumpAccounts
|
||||
| DumpAccountKeys
|
||||
| Sync
|
||||
|
||||
configFile :: Parser FilePath
|
||||
configFile = strOption
|
||||
configFile =
|
||||
strOption
|
||||
( long "config"
|
||||
<> short 'c'
|
||||
<> metavar "CONFIG"
|
||||
|
|
@ -43,7 +43,8 @@ configFile = strOption
|
|||
)
|
||||
|
||||
options :: Parser Options
|
||||
options = getConf reset
|
||||
options =
|
||||
getConf reset
|
||||
<|> getConf dumpCurrencies
|
||||
<|> getConf dumpAccounts
|
||||
<|> getConf dumpAccountKeys
|
||||
|
|
@ -52,21 +53,27 @@ options = getConf reset
|
|||
getConf m = Options <$> configFile <*> m
|
||||
|
||||
reset :: Parser Mode
|
||||
reset = flag' Reset
|
||||
reset =
|
||||
flag'
|
||||
Reset
|
||||
( long "reset"
|
||||
<> short 'R'
|
||||
<> help "Reset the database"
|
||||
)
|
||||
|
||||
dumpCurrencies :: Parser Mode
|
||||
dumpCurrencies = flag' DumpCurrencies
|
||||
dumpCurrencies =
|
||||
flag'
|
||||
DumpCurrencies
|
||||
( long "currencies"
|
||||
<> short 'C'
|
||||
<> help "Dump all currencies in the configuration"
|
||||
)
|
||||
|
||||
dumpAccounts :: Parser Mode
|
||||
dumpAccounts = flag' DumpAccounts
|
||||
dumpAccounts =
|
||||
flag'
|
||||
DumpAccounts
|
||||
( long "accounts"
|
||||
<> short 'A'
|
||||
<> help "Dump all accounts in the configuration"
|
||||
|
|
@ -74,14 +81,18 @@ dumpAccounts = flag' DumpAccounts
|
|||
|
||||
-- TODO 'alias' is a better name for these
|
||||
dumpAccountKeys :: Parser Mode
|
||||
dumpAccountKeys = flag' DumpAccountKeys
|
||||
dumpAccountKeys =
|
||||
flag'
|
||||
DumpAccountKeys
|
||||
( long "account_keys"
|
||||
<> short 'K'
|
||||
<> help "Dump all account keys/aliases"
|
||||
)
|
||||
|
||||
sync :: Parser Mode
|
||||
sync = flag' Sync
|
||||
sync =
|
||||
flag'
|
||||
Sync
|
||||
( long "sync"
|
||||
<> short 'S'
|
||||
<> help "Sync config to database"
|
||||
|
|
@ -109,7 +120,8 @@ runDumpAccounts c = do
|
|||
ar <- accounts <$> readConfig c
|
||||
mapM_ (\(h, f) -> printTree h $ f ar) ps
|
||||
where
|
||||
ps = [ ("Assets", arAssets)
|
||||
ps =
|
||||
[ ("Assets", arAssets)
|
||||
, ("Equity", arEquity)
|
||||
, ("Expenses", arExpenses)
|
||||
, ("Income", arIncome)
|
||||
|
|
@ -129,10 +141,11 @@ runDumpAccounts c = do
|
|||
runDumpAccountKeys :: FilePath -> IO ()
|
||||
runDumpAccountKeys c = do
|
||||
ar <- accounts <$> readConfig c
|
||||
let ks = paths2IDs
|
||||
$ fmap (double . fst)
|
||||
$ concatMap (t3 . uncurry tree2Records)
|
||||
$ flattenAcntRoot ar
|
||||
let ks =
|
||||
paths2IDs $
|
||||
fmap (double . fst) $
|
||||
concatMap (t3 . uncurry tree2Records) $
|
||||
flattenAcntRoot ar
|
||||
mapM_ (uncurry printPair) ks
|
||||
where
|
||||
printPair i p = do
|
||||
|
|
|
|||
24
budget.cabal
24
budget.cabal
|
|
@ -1,6 +1,6 @@
|
|||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.0.
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.1.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
|
|
@ -26,20 +26,19 @@ source-repository head
|
|||
library
|
||||
exposed-modules:
|
||||
Internal.Config
|
||||
Internal.Types
|
||||
Internal.Utils
|
||||
Internal.Database.Ops
|
||||
Internal.Database.Model
|
||||
Internal.Database.Ops
|
||||
Internal.Insert
|
||||
Internal.Statement
|
||||
Internal.Types
|
||||
Internal.Utils
|
||||
other-modules:
|
||||
Paths_budget
|
||||
hs-source-dirs:
|
||||
lib/
|
||||
ghc-options: -Wall -Werror -threaded -Wpartial-fields
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
|
||||
build-depends:
|
||||
base >=4.12 && <10
|
||||
, bytestring
|
||||
, cassava
|
||||
, conduit >=1.3.4.2
|
||||
, containers >=0.6.4.1
|
||||
|
|
@ -56,13 +55,10 @@ library
|
|||
, persistent-sqlite >=2.13.1.0
|
||||
, recursion-schemes
|
||||
, regex-tdfa
|
||||
, rio >=0.1.21.0
|
||||
, template-haskell
|
||||
, text >=1.2.5.0
|
||||
, time >=1.9.3
|
||||
, transformers
|
||||
, utf8-string
|
||||
, vector
|
||||
, yaml
|
||||
default-language: Haskell2010
|
||||
|
||||
executable pwncash
|
||||
|
|
@ -71,11 +67,10 @@ executable pwncash
|
|||
Paths_budget
|
||||
hs-source-dirs:
|
||||
app
|
||||
ghc-options: -Wall -Werror -threaded -Wpartial-fields -O2
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
|
||||
build-depends:
|
||||
base >=4.12 && <10
|
||||
, budget
|
||||
, bytestring
|
||||
, cassava
|
||||
, conduit >=1.3.4.2
|
||||
, containers >=0.6.4.1
|
||||
|
|
@ -92,11 +87,8 @@ executable pwncash
|
|||
, persistent-sqlite >=2.13.1.0
|
||||
, recursion-schemes
|
||||
, regex-tdfa
|
||||
, rio >=0.1.21.0
|
||||
, template-haskell
|
||||
, text >=1.2.5.0
|
||||
, time >=1.9.3
|
||||
, transformers
|
||||
, utf8-string
|
||||
, vector
|
||||
, yaml
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -1,76 +1,21 @@
|
|||
module Internal.Config
|
||||
( readConfig
|
||||
, readYaml
|
||||
) where
|
||||
|
||||
import Control.Exception
|
||||
-- import Control.Lens
|
||||
|
||||
-- import Data.Maybe
|
||||
-- import qualified Data.Text as T
|
||||
-- import Data.Typeable
|
||||
-- import Data.Void
|
||||
import Data.Yaml
|
||||
-- , readYaml
|
||||
)
|
||||
where
|
||||
|
||||
-- import Control.Exception
|
||||
-- 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 confpath = do
|
||||
-- let subs = DM.fromList typeSubs
|
||||
-- let settings = over substitutions (DM.union subs) defaultEvaluateSettings
|
||||
-- unfix <$> inputFileWithSettings settings auto confpath
|
||||
unfix <$> inputFile auto confpath
|
||||
|
||||
-- typeSubs :: [(T.Text, DC.Expr Src Void)]
|
||||
-- typeSubs = firstOrder ++ higherOrder
|
||||
-- where
|
||||
-- toVar a = fmap (\n -> (T.pack $ show n, maximum $ expected a))
|
||||
-- $ listToMaybe $ snd $ splitTyConApp $ typeOf a
|
||||
-- higherOrder =
|
||||
-- [ ("ExpSplit", maximum $ expected (auto :: Decoder ExpSplit))
|
||||
-- , ("ExpTx", maximum $ expected (auto :: Decoder ExpTx))
|
||||
-- , ("SplitCur", maximum $ expected (auto :: Decoder SplitCur))
|
||||
-- , ("SplitAcnt", maximum $ expected (auto :: Decoder SplitAcnt))
|
||||
-- , ("CurID", maximum $ expected (auto :: Decoder CurID))
|
||||
-- , ("AcntID", maximum $ expected (auto :: Decoder AcntID))
|
||||
-- ]
|
||||
-- firstOrder = catMaybes
|
||||
-- [ toVar (auto :: Decoder TimeUnit)
|
||||
-- , toVar (auto :: Decoder WeekdayPat)
|
||||
-- , toVar (auto :: Decoder MDYPat)
|
||||
-- , toVar (auto :: Decoder Gregorian)
|
||||
-- , toVar (auto :: Decoder GregorianM)
|
||||
-- , toVar (auto :: Decoder ModPat)
|
||||
-- , toVar (auto :: Decoder CronPat)
|
||||
-- , toVar (auto :: Decoder DatePat)
|
||||
-- , toVar (auto :: Decoder Income)
|
||||
-- , toVar (auto :: Decoder Tax)
|
||||
-- , toVar (auto :: Decoder Bucket)
|
||||
-- , toVar (auto :: Decoder TimeAmount)
|
||||
-- , toVar (auto :: Decoder Expense)
|
||||
-- , toVar (auto :: Decoder Decimal)
|
||||
-- , toVar (auto :: Decoder Statement)
|
||||
-- , toVar (auto :: Decoder Manual)
|
||||
-- , toVar (auto :: Decoder TxOpts)
|
||||
-- , toVar (auto :: Decoder ToTx)
|
||||
-- , toVar (auto :: Decoder Match)
|
||||
-- , toVar (auto :: Decoder MatchYMD)
|
||||
-- , toVar (auto :: Decoder MatchVal)
|
||||
-- , toVar (auto :: Decoder MatchDate)
|
||||
-- , toVar (auto :: Decoder SplitNum)
|
||||
-- , toVar (auto :: Decoder MatchDesc)
|
||||
-- , toVar (auto :: Decoder MatchOther)
|
||||
-- , toVar (auto :: Decoder SqlConfig)
|
||||
-- ]
|
||||
|
||||
readYaml :: FromJSON a => FilePath -> IO a
|
||||
readYaml p = do
|
||||
r <- decodeFileEither p
|
||||
case r of
|
||||
Right a -> return a
|
||||
Left e -> throw e
|
||||
-- readYaml :: FromJSON a => FilePath -> IO a
|
||||
-- readYaml p = do
|
||||
-- r <- decodeFileEither p
|
||||
-- case r of
|
||||
-- Right a -> return a
|
||||
-- Left e -> throw e
|
||||
|
|
|
|||
|
|
@ -17,18 +17,17 @@
|
|||
|
||||
module Internal.Database.Model where
|
||||
|
||||
import Control.Monad.Trans.Reader
|
||||
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Text as T
|
||||
import Data.Time
|
||||
|
||||
import Database.Esqueleto.Experimental
|
||||
import Database.Persist.TH
|
||||
|
||||
import Internal.Types
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
||||
share
|
||||
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||
[persistLowerCase|
|
||||
CommitR sql=commits
|
||||
hash Int
|
||||
type ConfigType
|
||||
|
|
|
|||
|
|
@ -14,34 +14,32 @@ module Internal.Database.Ops
|
|||
, tree2Records
|
||||
, flattenAcntRoot
|
||||
, paths2IDs
|
||||
|
||||
) where
|
||||
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Trans.Reader
|
||||
)
|
||||
where
|
||||
|
||||
import Conduit
|
||||
|
||||
import Data.Bifunctor
|
||||
import Data.Either
|
||||
import Control.Monad.Logger
|
||||
import Data.Hashable
|
||||
import Data.List ((\\))
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Database.Esqueleto.Experimental
|
||||
import Database.Persist.Sql hiding (delete, (==.), (||.))
|
||||
import Database.Persist.Sqlite hiding (delete, (==.), (||.))
|
||||
import Database.Sqlite hiding (Config)
|
||||
|
||||
import Internal.Database.Model
|
||||
import Internal.Types
|
||||
import Internal.Utils
|
||||
import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||
import RIO.List ((\\))
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
|
||||
migrate_ :: SqlConfig -> SqlPersistT (ResourceT (NoLoggingT IO)) () -> IO ()
|
||||
migrate_ c more = runNoLoggingT $ runResourceT
|
||||
$ withSqlConn (openConnection c) (\backend ->
|
||||
migrate_ c more =
|
||||
runNoLoggingT $
|
||||
runResourceT $
|
||||
withSqlConn
|
||||
(openConnection c)
|
||||
( \backend ->
|
||||
flip runSqlConn backend $ do
|
||||
runMigration migrateAll
|
||||
more
|
||||
|
|
@ -65,7 +63,8 @@ showBalances :: MonadIO m => SqlPersistT m ()
|
|||
showBalances = do
|
||||
xs <- select $ do
|
||||
(accounts :& splits :& txs) <-
|
||||
from $ table @AccountR
|
||||
from
|
||||
$ table @AccountR
|
||||
`innerJoin` table @SplitR
|
||||
`on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount)
|
||||
`innerJoin` table @TransactionR
|
||||
|
|
@ -73,11 +72,14 @@ showBalances = do
|
|||
where_ $
|
||||
isNothing (txs ^. TransactionRBucket)
|
||||
&&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%))
|
||||
||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%)))
|
||||
||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))
|
||||
)
|
||||
groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName)
|
||||
return ( accounts ^. AccountRFullpath
|
||||
return
|
||||
( accounts ^. AccountRFullpath
|
||||
, accounts ^. AccountRName
|
||||
, sum_ $ splits ^. SplitRValue)
|
||||
, sum_ $ splits ^. SplitRValue
|
||||
)
|
||||
-- TODO super stetchy table printing thingy
|
||||
liftIO $ do
|
||||
putStrLn $ T.unpack $ fmt "Account" "Balance"
|
||||
|
|
@ -91,8 +93,11 @@ showBalances = do
|
|||
toBal = maybe "???" (fmtRational 2) . unValue
|
||||
|
||||
hashConfig :: Config -> [Int]
|
||||
hashConfig Config_ { budget = Budget { expenses = xs, income = is }
|
||||
, statements = ss } =
|
||||
hashConfig
|
||||
Config_
|
||||
{ budget = Budget {expenses = xs, income = is}
|
||||
, statements = ss
|
||||
} =
|
||||
(hash <$> xs) ++ (hash <$> is) ++ (hash <$> ms) ++ (hash <$> ps)
|
||||
where
|
||||
(ms, ps) = partitionEithers $ fmap go ss
|
||||
|
|
@ -168,8 +173,10 @@ updateAccounts ar = do
|
|||
mapM_ insert paths
|
||||
return acntMap
|
||||
|
||||
insertFull :: (MonadIO m, PersistStoreWrite b, PersistRecordBackend r b)
|
||||
=> Entity r -> ReaderT b m ()
|
||||
insertFull
|
||||
:: (MonadIO m, PersistStoreWrite b, PersistRecordBackend r b)
|
||||
=> Entity r
|
||||
-> ReaderT b m ()
|
||||
insertFull (Entity k v) = insertKey k v
|
||||
|
||||
updateCurrencies :: MonadIO m => [Currency] -> SqlPersistT m CurrencyMap
|
||||
|
|
@ -191,20 +198,22 @@ toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
|||
toKey = toSqlKey . fromIntegral . hash
|
||||
|
||||
tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
|
||||
tree2Entity t parents name des = Entity (toSqlKey $ fromIntegral h)
|
||||
$ AccountR name (toPath parents) des
|
||||
tree2Entity t parents name des =
|
||||
Entity (toSqlKey $ fromIntegral h) $
|
||||
AccountR name (toPath parents) des
|
||||
where
|
||||
p = AcntPath t (reverse (name : parents))
|
||||
h = hash p
|
||||
toPath = T.intercalate "/" . (atName t :) . reverse
|
||||
|
||||
tree2Records :: AcntType -> AccountTree
|
||||
tree2Records
|
||||
:: AcntType
|
||||
-> AccountTree
|
||||
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign))])
|
||||
tree2Records t = go []
|
||||
where
|
||||
go ps (Placeholder d n cs) =
|
||||
let
|
||||
e = tree2Entity t (fmap snd ps) n d
|
||||
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
|
||||
|
|
@ -223,7 +232,8 @@ tree2Records t = go []
|
|||
sign = accountSign t
|
||||
|
||||
paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
|
||||
paths2IDs = uncurry zip
|
||||
paths2IDs =
|
||||
uncurry zip
|
||||
. first trimNames
|
||||
. unzip
|
||||
. L.sortOn fst
|
||||
|
|
@ -261,9 +271,15 @@ trimNames = fmap fmt . trimAll 0
|
|||
xs !? n
|
||||
| n < 0 = Nothing
|
||||
-- Definition adapted from GHC.List
|
||||
| otherwise = foldr (\x r k -> case k of
|
||||
| otherwise =
|
||||
foldr
|
||||
( \x r k -> case k of
|
||||
0 -> Just x
|
||||
_ -> r (k-1)) (const Nothing) xs n
|
||||
_ -> r (k - 1)
|
||||
)
|
||||
(const Nothing)
|
||||
xs
|
||||
n
|
||||
|
||||
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
|
||||
flattenAcntRoot AccountRoot_ {..} =
|
||||
|
|
@ -289,7 +305,8 @@ getDBState c = do
|
|||
hs <- updateHashes c
|
||||
-- TODO not sure how I feel about this, probably will change this struct alot
|
||||
-- in the future so whatever...for now
|
||||
return $ \f -> DBState
|
||||
return $ \f ->
|
||||
DBState
|
||||
{ kmCurrency = cm
|
||||
, kmAccount = am
|
||||
, kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c
|
||||
|
|
|
|||
|
|
@ -5,35 +5,28 @@
|
|||
module Internal.Insert
|
||||
( insertStatements
|
||||
, insertBudget
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
|
||||
import Data.Either
|
||||
import Data.Hashable
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Data.Time
|
||||
|
||||
import Database.Persist.Class
|
||||
import Database.Persist.Sql hiding (Single, Statement)
|
||||
|
||||
import Internal.Database.Model
|
||||
import Internal.Statement
|
||||
import Internal.Types hiding (sign)
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
import Numeric.Natural
|
||||
|
||||
lookupKey :: (Show v, Ord k, Show k, MonadIO m) => M.Map k v -> k -> m (Maybe v)
|
||||
lookupKey :: (Ord k, Show k, MonadIO m) => M.Map k v -> k -> m (Maybe v)
|
||||
lookupKey m k = do
|
||||
let v = M.lookup k m
|
||||
when (isNothing v) $
|
||||
liftIO $ putStrLn $ "key does not exist: " ++ show k
|
||||
liftIO $
|
||||
putStrLn $
|
||||
"key does not exist: " ++ show k
|
||||
return v
|
||||
|
||||
lookupAccount :: MonadIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign))
|
||||
|
|
@ -60,13 +53,16 @@ expandDatePat (a, b) (Cron cp) = filter (cronPatternMatches cp) [a..b]
|
|||
expandDatePat i (Mod mp) = expandModPat mp i
|
||||
|
||||
expandModPat :: ModPat -> Bounds -> [Day]
|
||||
expandModPat ModPat { mpStart = s
|
||||
expandModPat
|
||||
ModPat
|
||||
{ mpStart = s
|
||||
, mpBy = b
|
||||
, mpUnit = u
|
||||
, mpRepeats = r
|
||||
} (lower, upper) =
|
||||
takeWhile (<= upper)
|
||||
$ (`addFun` start) . (* b')
|
||||
}
|
||||
(lower, upper) =
|
||||
takeWhile (<= upper) $
|
||||
(`addFun` start) . (* b')
|
||||
<$> maybe id (take . fromIntegral) r [0 ..]
|
||||
where
|
||||
start = maybe lower fromGregorian' s
|
||||
|
|
@ -80,11 +76,14 @@ expandModPat ModPat { mpStart = s
|
|||
-- TODO this can be optimized to prevent filtering a bunch of dates for
|
||||
-- one/a few cron patterns
|
||||
cronPatternMatches :: CronPat -> Day -> Bool
|
||||
cronPatternMatches CronPat { cronWeekly = w
|
||||
cronPatternMatches
|
||||
CronPat
|
||||
{ cronWeekly = w
|
||||
, cronYear = y
|
||||
, cronMonth = m
|
||||
, cronDay = d
|
||||
} x =
|
||||
}
|
||||
x =
|
||||
yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w
|
||||
where
|
||||
testMaybe = maybe True
|
||||
|
|
@ -113,8 +112,8 @@ mdyPatternMatches check x p = case p of
|
|||
Single y -> errMaybe (check y) $ x == y
|
||||
Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs
|
||||
Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) ->
|
||||
errMaybe (check s)
|
||||
$ s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
|
||||
errMaybe (check s) $
|
||||
s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
|
||||
where
|
||||
errMaybe test rest = maybe rest err test
|
||||
err msg = error $ show p ++ ": " ++ msg
|
||||
|
|
@ -128,8 +127,13 @@ insertBudget Budget { income = is, expenses = es } = do
|
|||
mapM_ insertExpense es
|
||||
|
||||
-- TODO this hashes twice (not that it really matters)
|
||||
whenHash :: Hashable a => MonadIO m => ConfigType -> a
|
||||
-> (Key CommitR -> MappingT m ()) -> MappingT m ()
|
||||
whenHash
|
||||
:: Hashable a
|
||||
=> MonadIO m
|
||||
=> ConfigType
|
||||
-> a
|
||||
-> (Key CommitR -> MappingT m ())
|
||||
-> MappingT m ()
|
||||
whenHash t o f = do
|
||||
let h = hash o
|
||||
hs <- asks kmNewCommits
|
||||
|
|
@ -137,7 +141,9 @@ whenHash t o f = do
|
|||
f =<< lift (insert $ CommitR h t)
|
||||
|
||||
insertIncome :: MonadIO m => Income -> MappingT m ()
|
||||
insertIncome i@Income { incCurrency = cur
|
||||
insertIncome
|
||||
i@Income
|
||||
{ incCurrency = cur
|
||||
, incWhen = dp
|
||||
, incAccount = from
|
||||
, incTaxes = ts
|
||||
|
|
@ -153,7 +159,9 @@ insertIncome i@Income { incCurrency = cur
|
|||
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx
|
||||
|
||||
balanceIncome :: Income -> Either T.Text [BalAllocation]
|
||||
balanceIncome Income { incGross = g
|
||||
balanceIncome
|
||||
Income
|
||||
{ incGross = g
|
||||
, incPretax = pre
|
||||
, incTaxes = tax
|
||||
, incPosttax = post
|
||||
|
|
@ -177,8 +185,8 @@ balancePostTax bal as
|
|||
| null as = Left "no allocations to balance"
|
||||
| otherwise = case partitionEithers $ fmap hasVal as of
|
||||
([([empty], nonmissing)], bs) ->
|
||||
let s = bal - sumAllocations (nonmissing:bs) in
|
||||
if s < 0
|
||||
let s = bal - sumAllocations (nonmissing : bs)
|
||||
in if s < 0
|
||||
then Left "allocations exceed total"
|
||||
else Right $ mapAmts (empty {amtValue = s} :) nonmissing : bs
|
||||
([], _) -> Left "need one blank amount to balance"
|
||||
|
|
@ -195,9 +203,17 @@ balancePostTax bal as
|
|||
mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b
|
||||
mapAmts f a@Allocation {alloAmts = xs} = a {alloAmts = f xs}
|
||||
|
||||
allocationToTx :: MonadIO m => AcntID -> Day -> BalAllocation
|
||||
allocationToTx
|
||||
:: MonadIO m
|
||||
=> AcntID
|
||||
-> Day
|
||||
-> BalAllocation
|
||||
-> MappingT m [(KeyTx, Bucket)]
|
||||
allocationToTx from day Allocation { alloPath = to
|
||||
allocationToTx
|
||||
from
|
||||
day
|
||||
Allocation
|
||||
{ alloPath = to
|
||||
, alloBucket = b
|
||||
, alloCurrency = cur
|
||||
, alloAmts = as
|
||||
|
|
@ -208,13 +224,21 @@ taxToTx :: MonadIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx
|
|||
taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
|
||||
txPair day from to cur (dec2Rat v) ""
|
||||
|
||||
transferToTx :: MonadIO m => Day -> AcntID -> AcntID -> T.Text -> BalAmount
|
||||
transferToTx
|
||||
:: MonadIO m
|
||||
=> Day
|
||||
-> AcntID
|
||||
-> AcntID
|
||||
-> T.Text
|
||||
-> BalAmount
|
||||
-> MappingT m KeyTx
|
||||
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
|
||||
txPair day from to cur v d
|
||||
|
||||
insertExpense :: MonadIO m => Expense -> MappingT m ()
|
||||
insertExpense e@Expense { expFrom = from
|
||||
insertExpense
|
||||
e@Expense
|
||||
{ expFrom = from
|
||||
, expTo = to
|
||||
, expCurrency = cur
|
||||
, expBucket = buc
|
||||
|
|
@ -224,12 +248,25 @@ insertExpense e@Expense { expFrom = from
|
|||
ts <- concat <$> mapM (timeAmountToTx from to cur) as
|
||||
lift $ mapM_ (insertTxBucket (Just buc) c) ts
|
||||
|
||||
timeAmountToTx :: MonadIO m => AcntID -> AcntID -> T.Text -> TimeAmount
|
||||
timeAmountToTx
|
||||
:: MonadIO m
|
||||
=> AcntID
|
||||
-> AcntID
|
||||
-> T.Text
|
||||
-> TimeAmount
|
||||
-> MappingT m [KeyTx]
|
||||
timeAmountToTx from to cur TimeAmount { taWhen = dp
|
||||
, taAmt = Amount { amtValue = v
|
||||
timeAmountToTx
|
||||
from
|
||||
to
|
||||
cur
|
||||
TimeAmount
|
||||
{ taWhen = dp
|
||||
, taAmt =
|
||||
Amount
|
||||
{ amtValue = v
|
||||
, amtDesc = d
|
||||
} } = do
|
||||
}
|
||||
} = do
|
||||
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
||||
mapM tx $ expandDatePat bounds dp
|
||||
where
|
||||
|
|
@ -246,7 +283,9 @@ insertStatement (StmtManual m) = insertManual m
|
|||
insertStatement (StmtImport i) = insertImport i
|
||||
|
||||
insertManual :: MonadIO m => Manual -> MappingT m ()
|
||||
insertManual m@Manual { manualDate = dp
|
||||
insertManual
|
||||
m@Manual
|
||||
{ manualDate = dp
|
||||
, manualFrom = from
|
||||
, manualTo = to
|
||||
, manualValue = v
|
||||
|
|
@ -272,12 +311,21 @@ insertImport i = whenHash CTImport i $ \c -> do
|
|||
--------------------------------------------------------------------------------
|
||||
-- low-level transaction stuff
|
||||
|
||||
txPair :: MonadIO m => Day -> AcntID -> AcntID -> T.Text -> Rational -> T.Text
|
||||
txPair
|
||||
:: MonadIO m
|
||||
=> Day
|
||||
-> AcntID
|
||||
-> AcntID
|
||||
-> T.Text
|
||||
-> Rational
|
||||
-> T.Text
|
||||
-> MappingT m KeyTx
|
||||
txPair day from to cur val desc = resolveTx tx
|
||||
where
|
||||
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
|
||||
tx = Tx { txDescr = desc
|
||||
tx =
|
||||
Tx
|
||||
{ txDescr = desc
|
||||
, txDate = day
|
||||
, txTags = []
|
||||
, txSplits = [split from (-val), split to val]
|
||||
|
|
@ -296,8 +344,10 @@ resolveSplit s@Split { sAcnt = p, sCurrency = c, sValue = v } = do
|
|||
-- TODO correct sign here?
|
||||
-- TODO lenses would be nice here
|
||||
return $ case (aid, cid, sign) of
|
||||
(Just aid', Just cid', Just sign')
|
||||
-> Just $ s { sAcnt = aid'
|
||||
(Just aid', Just cid', Just sign') ->
|
||||
Just $
|
||||
s
|
||||
{ sAcnt = aid'
|
||||
, sCurrency = cid'
|
||||
, sValue = v * fromIntegral (sign2Int sign')
|
||||
}
|
||||
|
|
|
|||
|
|
@ -3,38 +3,29 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Internal.Statement
|
||||
( readImport
|
||||
module Internal.Statement (
|
||||
readImport,
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
|
||||
import Data.Bifunctor
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Csv
|
||||
import Data.Either
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.Ord
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.Time
|
||||
import qualified Data.Vector as V
|
||||
|
||||
import Internal.Database.Model
|
||||
import Internal.Types
|
||||
import Internal.Utils
|
||||
|
||||
import Numeric.Natural
|
||||
|
||||
import System.FilePath
|
||||
import RIO
|
||||
import qualified RIO.ByteString.Lazy as BL
|
||||
import RIO.FilePath
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
import qualified RIO.Vector as V
|
||||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
|
||||
readImport :: MonadIO m => Import -> MappingT m [BalTx]
|
||||
readImport Import { impPaths = ps
|
||||
readImport
|
||||
Import
|
||||
{ impPaths = ps
|
||||
, impMatches = ms
|
||||
, impTxOpts = ns
|
||||
, impDelim = d
|
||||
|
|
@ -46,8 +37,13 @@ readImport Import { impPaths = ps
|
|||
liftIO $ mapM_ print notfound
|
||||
return ts
|
||||
|
||||
readImport_ :: MonadIO m => Natural -> Word -> TxOpts -> FilePath
|
||||
-> MappingT m [TxRecord]
|
||||
readImport_ ::
|
||||
MonadIO m =>
|
||||
Natural ->
|
||||
Word ->
|
||||
TxOpts ->
|
||||
FilePath ->
|
||||
MappingT m [TxRecord]
|
||||
readImport_ n delim tns p = do
|
||||
dir <- asks kmConfigDir
|
||||
bs <- liftIO $ BL.readFile $ dir </> p
|
||||
|
|
@ -62,43 +58,48 @@ readImport_ n delim tns p = do
|
|||
-- blank dates but will likely want to make this more flexible
|
||||
parseTxRecord :: TxOpts -> NamedRecord -> Parser (Maybe TxRecord)
|
||||
parseTxRecord TxOpts{..} r = do
|
||||
d <- r .: TE.encodeUtf8 toDate
|
||||
d <- r .: T.encodeUtf8 toDate
|
||||
if d == ""
|
||||
then return Nothing
|
||||
else do
|
||||
a <- parseRational toAmountFmt =<< r .: TE.encodeUtf8 toAmount
|
||||
e <- r .: TE.encodeUtf8 toDesc
|
||||
os <- M.fromList <$> mapM (\n -> (n, ) <$> r .: TE.encodeUtf8 n) toOther
|
||||
a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
||||
e <- r .: T.encodeUtf8 toDesc
|
||||
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
|
||||
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
||||
return $ Just $ TxRecord d' a e os
|
||||
|
||||
matchRecords :: [Match] -> [TxRecord] -> ([BalTx], [String], [Match])
|
||||
matchRecords ms rs = ( catMaybes ts
|
||||
matchRecords ms rs =
|
||||
( catMaybes ts
|
||||
, T.unpack <$> (es ++ bu)
|
||||
-- TODO record number of times each match hits for debugging
|
||||
, notfound
|
||||
, -- TODO record number of times each match hits for debugging
|
||||
notfound
|
||||
)
|
||||
where
|
||||
(matched, unmatched, notfound) = matchAll (matchPriorities ms) rs
|
||||
(es, ts) = partitionEithers
|
||||
$ fmap Just . balanceTx <$> catMaybes matched
|
||||
(es, ts) =
|
||||
partitionEithers $
|
||||
fmap Just . balanceTx <$> catMaybes matched
|
||||
bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched
|
||||
|
||||
matchPriorities :: [Match] -> [MatchGroup]
|
||||
matchPriorities = fmap matchToGroup
|
||||
matchPriorities =
|
||||
fmap matchToGroup
|
||||
. L.groupBy (\a b -> mPriority a == mPriority b)
|
||||
. L.sortOn (Down . mPriority)
|
||||
|
||||
matchToGroup :: [Match] -> MatchGroup
|
||||
matchToGroup ms = uncurry MatchGroup
|
||||
$ first (L.sortOn mDate)
|
||||
$ L.partition (isJust . mDate) ms
|
||||
matchToGroup ms =
|
||||
uncurry MatchGroup $
|
||||
first (L.sortOn mDate) $
|
||||
L.partition (isJust . mDate) ms
|
||||
|
||||
-- TDOO could use a better struct to flatten the maybe date subtype
|
||||
data MatchGroup = MatchGroup
|
||||
{ mgDate :: [Match]
|
||||
, mgNoDate :: [Match]
|
||||
} deriving (Show)
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Zipped a = Zipped ![a] ![a]
|
||||
|
||||
|
|
@ -133,9 +134,10 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
|
|||
go _ [] = (Zipped bs $ cs ++ as, Nothing)
|
||||
go prev (m : ms) = case matches m x of
|
||||
Nothing -> go (m : prev) ms
|
||||
res@(Just _) -> let ps = reverse prev
|
||||
ms' = maybe ms (:ms) (matchDec m) in
|
||||
(Zipped bs $ ps ++ ms' ++ as, res)
|
||||
res@(Just _) ->
|
||||
let ps = reverse prev
|
||||
ms' = maybe ms (: ms) (matchDec m)
|
||||
in (Zipped bs $ ps ++ ms' ++ as, res)
|
||||
|
||||
zipperMatch' :: Zipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
|
||||
zipperMatch' z x = go z
|
||||
|
|
@ -157,12 +159,13 @@ matchAll = go ([], [])
|
|||
go (matched, unused) gs rs = case (gs, rs) of
|
||||
(_, []) -> (matched, [], unused)
|
||||
([], _) -> (matched, rs, unused)
|
||||
(g:gs', _) -> let (ts, unmatched, us) = matchGroup g rs in
|
||||
go (ts ++ matched, us ++ unused) gs' unmatched
|
||||
(g : gs', _) ->
|
||||
let (ts, unmatched, us) = matchGroup g rs
|
||||
in go (ts ++ matched, us ++ unused) gs' unmatched
|
||||
|
||||
matchGroup :: MatchGroup -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
|
||||
matchGroup MatchGroup { mgDate = ds, mgNoDate = ns } rs
|
||||
= (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
|
||||
matchGroup MatchGroup{mgDate = ds, mgNoDate = ns} rs =
|
||||
(md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
|
||||
where
|
||||
(md, rest, ud) = matchDates ds rs
|
||||
(mn, unmatched, un) = matchNonDates ns rest
|
||||
|
|
@ -198,7 +201,8 @@ balanceTx t@Tx { txSplits = ss } = do
|
|||
return $ t{txSplits = bs}
|
||||
|
||||
balanceSplits :: [RawSplit] -> Either T.Text [BalSplit]
|
||||
balanceSplits ss = fmap concat
|
||||
balanceSplits ss =
|
||||
fmap concat
|
||||
<$> mapM (uncurry bal)
|
||||
$ groupByKey
|
||||
$ fmap (\s -> (sCurrency s, s)) ss
|
||||
|
|
|
|||
|
|
@ -17,26 +17,21 @@ module Internal.Types where
|
|||
import Data.Fix (Fix (..), foldFix)
|
||||
import Data.Functor.Foldable (embed)
|
||||
import qualified Data.Functor.Foldable.TH as TH
|
||||
import Data.Hashable
|
||||
import Data.Int
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Text as T
|
||||
import Data.Time
|
||||
|
||||
import Database.Persist.Sql hiding (In, Statement)
|
||||
|
||||
import Dhall hiding (embed, maybe)
|
||||
import Dhall.TH
|
||||
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
|
||||
import Text.Read
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- | YAML CONFIG
|
||||
-- YAML CONFIG
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False })
|
||||
makeHaskellTypesWith
|
||||
(defaultGenerateOptions{generateToDhallInstance = False})
|
||||
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
||||
, MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
|
||||
, MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
|
||||
|
|
@ -47,7 +42,6 @@ makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False }
|
|||
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
|
||||
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
|
||||
, MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket"
|
||||
|
||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||
|
|
@ -64,9 +58,10 @@ makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False }
|
|||
]
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- | account tree
|
||||
-- account tree
|
||||
|
||||
data AccountTree = Placeholder T.Text T.Text [AccountTree]
|
||||
data AccountTree
|
||||
= Placeholder T.Text T.Text [AccountTree]
|
||||
| Account T.Text T.Text
|
||||
|
||||
TH.makeBaseFunctor ''AccountTree
|
||||
|
|
@ -90,16 +85,17 @@ deriving instance FromDhall AccountRootF
|
|||
type AccountRoot = AccountRoot_ AccountTree
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- | curencies
|
||||
-- curencies
|
||||
|
||||
deriving instance Eq Currency
|
||||
|
||||
deriving instance Lift Currency
|
||||
deriving instance Hashable Currency
|
||||
|
||||
type CurID = T.Text
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- | DHALL CONFIG
|
||||
-- DHALL CONFIG
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
data Config_ a = Config_
|
||||
|
|
@ -119,7 +115,8 @@ type Config = Config_ AccountRoot
|
|||
unfix :: ConfigF -> Config
|
||||
unfix c@Config_{accounts = a} = c{accounts = a'}
|
||||
where
|
||||
a' = AccountRoot_
|
||||
a' =
|
||||
AccountRoot_
|
||||
{ arAssets = unfixTree arAssets
|
||||
, arEquity = unfixTree arEquity
|
||||
, arExpenses = unfixTree arExpenses
|
||||
|
|
@ -131,14 +128,15 @@ unfix c@Config_ { accounts = a } = c { accounts = a' }
|
|||
instance FromDhall a => FromDhall (Config_ a)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- | accounts
|
||||
-- accounts
|
||||
|
||||
type AcntID = T.Text
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Time Patterns (for assigning when budget events will happen)
|
||||
-- Time Patterns (for assigning when budget events will happen)
|
||||
|
||||
deriving instance Eq TimeUnit
|
||||
|
||||
deriving instance Hashable TimeUnit
|
||||
|
||||
deriving instance Eq Weekday
|
||||
|
|
@ -167,7 +165,8 @@ deriving instance Hashable GregorianM
|
|||
instance Ord Gregorian where
|
||||
compare
|
||||
Gregorian{gYear = y, gMonth = m, gDay = d}
|
||||
Gregorian { gYear = y', gMonth = m', gDay = d'} = compare y y'
|
||||
Gregorian{gYear = y', gMonth = m', gDay = d'} =
|
||||
compare y y'
|
||||
<> compare m m'
|
||||
<> compare d d'
|
||||
|
||||
|
|
@ -186,7 +185,7 @@ deriving instance Eq DatePat
|
|||
deriving instance Hashable DatePat
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Budget (projecting into the future)
|
||||
-- Budget (projecting into the future)
|
||||
|
||||
data Income = Income
|
||||
{ incGross :: !Decimal
|
||||
|
|
@ -211,7 +210,8 @@ deriving instance Hashable Tax
|
|||
data Amount v = Amount
|
||||
{ amtValue :: !v
|
||||
, amtDesc :: !T.Text
|
||||
} deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall)
|
||||
}
|
||||
deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
data Allocation v = Allocation
|
||||
{ alloPath :: !AcntID
|
||||
|
|
@ -241,9 +241,10 @@ data Expense = Expense
|
|||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Statements (data from the past)
|
||||
-- Statements (data from the past)
|
||||
|
||||
data Statement = StmtManual Manual
|
||||
data Statement
|
||||
= StmtManual Manual
|
||||
| StmtImport Import
|
||||
deriving (Generic, FromDhall)
|
||||
|
||||
|
|
@ -269,7 +270,7 @@ data Tx s = Tx
|
|||
|
||||
type ExpTx = Tx ExpSplit
|
||||
|
||||
instance FromDhall ExpTx where
|
||||
instance FromDhall ExpTx
|
||||
|
||||
data Import = Import
|
||||
{ impPaths :: ![FilePath]
|
||||
|
|
@ -305,8 +306,8 @@ instance Ord MatchYMD where
|
|||
compare (YMD g) (YM g') = compare (gregM g) g' <> GT
|
||||
|
||||
gregM :: Gregorian -> GregorianM
|
||||
gregM Gregorian { gYear = y, gMonth = m}
|
||||
= GregorianM { gmYear = y, gmMonth = m}
|
||||
gregM Gregorian{gYear = y, gMonth = m} =
|
||||
GregorianM{gmYear = y, gmMonth = m}
|
||||
|
||||
instance Ord MatchDate where
|
||||
compare (On d) (On d') = compare d d'
|
||||
|
|
@ -318,10 +319,12 @@ deriving instance Eq SplitNum
|
|||
deriving instance Hashable SplitNum
|
||||
deriving instance Show SplitNum
|
||||
|
||||
-- | the value of a field in split (text version)
|
||||
-- can either be a raw (constant) value, a lookup from the record, or a map
|
||||
-- between the lookup and some other value
|
||||
data SplitText t = ConstT !t
|
||||
{- | the value of a field in split (text version)
|
||||
can either be a raw (constant) value, a lookup from the record, or a map
|
||||
between the lookup and some other value
|
||||
-}
|
||||
data SplitText t
|
||||
= ConstT !t
|
||||
| LookupT !T.Text
|
||||
| MapT (FieldMap T.Text t)
|
||||
| Map2T (FieldMap (T.Text, T.Text) t)
|
||||
|
|
@ -339,7 +342,8 @@ data Field k v = Field
|
|||
|
||||
type FieldMap k v = Field k (M.Map k v)
|
||||
|
||||
data MatchOther = Desc (Field T.Text T.Text)
|
||||
data MatchOther
|
||||
= Desc (Field T.Text T.Text)
|
||||
| Val (Field T.Text MatchVal)
|
||||
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
|
|
@ -366,14 +370,15 @@ deriving instance Hashable TxOpts
|
|||
deriving instance Show TxOpts
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Specialized dhall types
|
||||
-- Specialized dhall types
|
||||
|
||||
deriving instance Eq Decimal
|
||||
|
||||
deriving instance Hashable Decimal
|
||||
deriving instance Show Decimal
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | database cache types
|
||||
-- database cache types
|
||||
|
||||
data ConfigHashes = ConfigHashes
|
||||
{ chIncome :: ![Int]
|
||||
|
|
@ -390,15 +395,17 @@ instance PersistFieldSql ConfigType where
|
|||
|
||||
instance PersistField ConfigType where
|
||||
toPersistValue = PersistText . T.pack . show
|
||||
|
||||
-- TODO these error messages *might* be good enough?
|
||||
fromPersistValue (PersistText v) =
|
||||
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
||||
fromPersistValue _ = Left "wrong type"
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- | misc
|
||||
-- misc
|
||||
|
||||
data AcntType = AssetT
|
||||
data AcntType
|
||||
= AssetT
|
||||
| EquityT
|
||||
| ExpenseT
|
||||
| IncomeT
|
||||
|
|
@ -415,7 +422,8 @@ atName LiabilityT = "liability"
|
|||
data AcntPath = AcntPath
|
||||
{ apType :: !AcntType
|
||||
, apChildren :: ![T.Text]
|
||||
} deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
|
||||
}
|
||||
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
|
||||
|
||||
data TxRecord = TxRecord
|
||||
{ trDate :: !Day
|
||||
|
|
@ -435,7 +443,7 @@ data Keyed a = Keyed
|
|||
}
|
||||
deriving (Eq, Show, Functor)
|
||||
|
||||
data Tree a = Branch !a ![Tree a] | Leaf !a deriving Show
|
||||
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
|
||||
|
||||
data AcntSign = Credit | Debit
|
||||
deriving (Show)
|
||||
|
|
|
|||
|
|
@ -4,19 +4,13 @@
|
|||
|
||||
module Internal.Utils where
|
||||
|
||||
import Data.Bifunctor
|
||||
import qualified Data.Map as M
|
||||
import Data.Ratio
|
||||
import qualified Data.Text as T
|
||||
import Data.Time
|
||||
|
||||
import GHC.Real
|
||||
|
||||
import Numeric.Natural
|
||||
|
||||
import Internal.Types
|
||||
|
||||
import Text.Read
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import qualified RIO.Text.Partial as TP
|
||||
import RIO.Time
|
||||
import Text.Regex.TDFA
|
||||
|
||||
-- when bifunctor fails...
|
||||
|
|
@ -26,15 +20,19 @@ thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
|
|||
gregTup :: Gregorian -> (Integer, Int, Int)
|
||||
gregTup g@Gregorian {..}
|
||||
| gYear > 99 = error $ show g ++ ": year must only be two digits"
|
||||
| otherwise = ( fromIntegral gYear + 2000
|
||||
| otherwise =
|
||||
( fromIntegral gYear + 2000
|
||||
, fromIntegral gMonth
|
||||
, fromIntegral gDay)
|
||||
, fromIntegral gDay
|
||||
)
|
||||
|
||||
gregMTup :: GregorianM -> (Integer, Int)
|
||||
gregMTup g@GregorianM {..}
|
||||
| gmYear > 99 = error $ show g ++ ": year must only be two digits"
|
||||
| otherwise = ( fromIntegral gmYear + 2000
|
||||
, fromIntegral gmMonth)
|
||||
| otherwise =
|
||||
( fromIntegral gmYear + 2000
|
||||
, fromIntegral gmMonth
|
||||
)
|
||||
|
||||
data MDY_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int
|
||||
|
||||
|
|
@ -56,7 +54,8 @@ compareDate (On md) x = case fromMatchYMD md of
|
|||
compareDate (In md offset) x = case fromMatchYMD md of
|
||||
Y_ y' -> compareRange y' y
|
||||
YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
|
||||
YMD_ y' m' d' -> let s = toModifiedJulianDay $ fromGregorian y' m' d'
|
||||
YMD_ y' m' d' ->
|
||||
let s = toModifiedJulianDay $ fromGregorian y' m' d'
|
||||
in compareRange s $ toModifiedJulianDay x
|
||||
where
|
||||
(y, m, _) = toGregorian x
|
||||
|
|
@ -69,7 +68,8 @@ dateMatches :: MatchDate -> Day -> Bool
|
|||
dateMatches md = (EQ ==) . compareDate md
|
||||
|
||||
valMatches :: MatchVal -> Rational -> Bool
|
||||
valMatches MatchVal {..} x = checkMaybe (s ==) mvSign
|
||||
valMatches MatchVal {..} x =
|
||||
checkMaybe (s ==) mvSign
|
||||
&& checkMaybe (n ==) mvNum
|
||||
&& checkMaybe ((d * p ==) . fromIntegral) mvDen
|
||||
where
|
||||
|
|
@ -79,16 +79,19 @@ valMatches MatchVal {..} x = checkMaybe (s ==) mvSign
|
|||
|
||||
evalSplit :: TxRecord -> ExpSplit -> RawSplit
|
||||
evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
|
||||
s { sAcnt = evalAcnt r a
|
||||
s
|
||||
{ sAcnt = evalAcnt r a
|
||||
, sValue = evalExp r =<< v
|
||||
, sCurrency = evalCurrency r c }
|
||||
, sCurrency = evalCurrency r c
|
||||
}
|
||||
|
||||
evalAcnt :: TxRecord -> SplitAcnt -> T.Text
|
||||
evalAcnt TxRecord {trOther = o} s = case s of
|
||||
ConstT p -> p
|
||||
LookupT f -> read $ T.unpack $ lookupField f o
|
||||
MapT (Field f m) -> let k = lookupField f o in lookupErr "account key" k m
|
||||
Map2T (Field (f1, f2) m) -> let k1 = lookupField f1 o
|
||||
Map2T (Field (f1, f2) m) ->
|
||||
let k1 = lookupField f1 o
|
||||
k2 = lookupField f2 o
|
||||
in lookupErr "account key" (k1, k2) m
|
||||
|
||||
|
|
@ -97,7 +100,8 @@ evalCurrency TxRecord { trOther = o } s = case s of
|
|||
ConstT p -> p
|
||||
LookupT f -> lookupField f o
|
||||
MapT (Field f m) -> let k = lookupField f o in lookupErr "currency key" k m
|
||||
Map2T (Field (f1, f2) m) -> let k1 = lookupField f1 o
|
||||
Map2T (Field (f1, f2) m) ->
|
||||
let k1 = lookupField f1 o
|
||||
k2 = lookupField f2 o
|
||||
in lookupErr "currency key" (k1, k2) m
|
||||
|
||||
|
|
@ -117,7 +121,8 @@ matches Match {..} r@TxRecord {..}
|
|||
| allPass = Just $ fmap eval mTx
|
||||
| otherwise = Nothing
|
||||
where
|
||||
allPass = checkMaybe (`dateMatches` trDate) mDate
|
||||
allPass =
|
||||
checkMaybe (`dateMatches` trDate) mDate
|
||||
&& valMatches mVal trAmount
|
||||
&& checkMaybe (=~ trDesc) mDesc
|
||||
&& all (fieldMatches trOther) mOther
|
||||
|
|
@ -138,13 +143,16 @@ checkMaybe = maybe True
|
|||
|
||||
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> RawTx
|
||||
toTx sc sa toSplits r@TxRecord {..} =
|
||||
Tx { txTags = []
|
||||
Tx
|
||||
{ txTags = []
|
||||
, txDate = trDate
|
||||
, txDescr = trDesc
|
||||
, txSplits = fromSplit : fmap (evalSplit r) toSplits
|
||||
}
|
||||
where
|
||||
fromSplit = Split { sAcnt = evalAcnt r sa
|
||||
fromSplit =
|
||||
Split
|
||||
{ sAcnt = evalAcnt r sa
|
||||
, sCurrency = evalCurrency r sc
|
||||
, sValue = Just trAmount
|
||||
, sComment = ""
|
||||
|
|
@ -164,9 +172,15 @@ parseRational pat s = case ms of
|
|||
readT what t = case readMaybe $ T.unpack t of
|
||||
Just d -> return $ fromInteger d
|
||||
_ -> msg $ T.unwords ["could not parse", what, t]
|
||||
msg m = fail $ T.unpack $ T.concat [ m
|
||||
, "; pattern = ", pat
|
||||
, "; query = ", s
|
||||
msg m =
|
||||
fail $
|
||||
T.unpack $
|
||||
T.concat
|
||||
[ m
|
||||
, "; pattern = "
|
||||
, pat
|
||||
, "; query = "
|
||||
, s
|
||||
]
|
||||
readSign x
|
||||
| x == "-" = return (-1)
|
||||
|
|
@ -177,14 +191,16 @@ parseRational pat s = case ms of
|
|||
k <- readSign sign
|
||||
return (k, w)
|
||||
|
||||
-- TODO don't use a partial function
|
||||
readRational :: MonadFail m => T.Text -> m Rational
|
||||
readRational s = case T.splitOn "." s of
|
||||
readRational s = case TP.splitOn "." s of
|
||||
[x] -> return $ fromInteger $ readT x
|
||||
[x, y] -> let x' = readT x
|
||||
[x, y] ->
|
||||
let x' = readT x
|
||||
y' = readT y
|
||||
p = 10 ^ T.length y
|
||||
k = if x' >= 0 then 1 else -1 in
|
||||
if y' > p
|
||||
k = if x' >= 0 then 1 else -1
|
||||
in if y' > p
|
||||
then fail "not enough precision to parse"
|
||||
else return $ fromInteger x' + k * y' % p
|
||||
_ -> fail $ T.unpack $ T.append "malformed decimal: " s
|
||||
|
|
@ -225,8 +241,8 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
|
|||
s = if x >= 0 then "" else "-"
|
||||
x'@(n :% d) = abs x
|
||||
p = 10 ^ precision
|
||||
n' = toInteger $ div n d
|
||||
d' = toInteger $ (\(a:%b) -> div a b) ((x' - fromIntegral n') * p)
|
||||
n' = div n d
|
||||
d' = (\(a :% b) -> div a b) ((x' - fromIntegral n') * p)
|
||||
txt = T.pack . show
|
||||
pad i c z = T.append (T.replicate (i - T.length z) c) z
|
||||
|
||||
|
|
|
|||
33
package.yaml
33
package.yaml
|
|
@ -21,7 +21,7 @@ description: Please see the README on GitHub at <https://github.com/ndwa
|
|||
|
||||
dependencies:
|
||||
- base >= 4.12 && < 10
|
||||
# - rio >= 0.1.22.0
|
||||
- rio >= 0.1.21.0
|
||||
- persistent >= 2.13.3.1
|
||||
- persistent-sqlite >= 2.13.1.0
|
||||
- monad-logger >= 0.3.36
|
||||
|
|
@ -33,15 +33,10 @@ dependencies:
|
|||
- containers >= 0.6.4.1
|
||||
- ghc >= 9.0.2
|
||||
- cassava
|
||||
- bytestring
|
||||
- vector
|
||||
- regex-tdfa
|
||||
- utf8-string
|
||||
- transformers
|
||||
- esqueleto
|
||||
- template-haskell
|
||||
- hashable
|
||||
- yaml
|
||||
- optparse-applicative
|
||||
- recursion-schemes
|
||||
- data-fix
|
||||
|
|
@ -51,17 +46,14 @@ library:
|
|||
source-dirs: lib/
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -threaded
|
||||
- -Wcompat
|
||||
- -Widentities
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wpartial-fields
|
||||
exposed-modules:
|
||||
- Internal.Config
|
||||
- Internal.Types
|
||||
- Internal.Utils
|
||||
- Internal.Database.Ops
|
||||
- Internal.Database.Model
|
||||
- Internal.Insert
|
||||
- Internal.Statement
|
||||
- -Werror
|
||||
- -O2
|
||||
|
||||
executables:
|
||||
pwncash:
|
||||
|
|
@ -69,9 +61,14 @@ executables:
|
|||
source-dirs: app
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -threaded
|
||||
- -Wcompat
|
||||
- -Widentities
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wpartial-fields
|
||||
- -Werror
|
||||
- -O2
|
||||
- -threaded
|
||||
dependencies:
|
||||
- budget
|
||||
|
|
|
|||
Loading…
Reference in New Issue