ENH use rio modules everywhere and use recommended flags

This commit is contained in:
Nathan Dwarshuis 2023-01-05 22:16:06 -05:00
parent c5e32aee48
commit 20cc4db986
10 changed files with 971 additions and 930 deletions

View File

@ -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"
@ -101,7 +112,7 @@ runDumpCurrencies c = do
cs <- currencies <$> readConfig c
putStrLn $ T.unpack $ T.unlines $ fmap fmt cs
where
fmt Currency { curSymbol = s, curFullname = f } =
fmt Currency {curSymbol = s, curFullname = f} =
T.concat [s, ": ", f]
runDumpAccounts :: FilePath -> IO ()
@ -109,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

View File

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

View File

@ -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

View File

@ -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

View File

@ -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,19 +63,23 @@ 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
`on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId)
where_ $
isNothing (txs ^. TransactionRBucket)
&&. ((accounts ^. AccountRFullpath `like` val "asset" ++. (%))
||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%)))
&&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%))
||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))
)
groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName)
return ( accounts ^. AccountRFullpath
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,39 +198,42 @@ toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
toKey = toSqlKey . fromIntegral . hash
tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
tree2Entity t parents name des = Entity (toSqlKey $ fromIntegral h)
$ AccountR name (toPath parents) des
tree2Entity t parents name des =
Entity (toSqlKey $ fromIntegral h) $
AccountR name (toPath parents) des
where
p = AcntPath t (reverse (name:parents))
p = AcntPath t (reverse (name : parents))
h = hash p
toPath = T.intercalate "/" . (atName t:) . reverse
toPath = T.intercalate "/" . (atName t :) . reverse
tree2Records :: AcntType -> AccountTree
tree2Records
:: AcntType
-> AccountTree
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign))])
tree2Records t = go []
where
go ps (Placeholder d n cs) =
let
e = tree2Entity t (fmap snd ps) n d
let e = tree2Entity t (fmap snd ps) n d
k = entityKey e
(as, aps, ms) = unzip3 $ fmap (go ((k, n):ps)) cs
(as, aps, ms) = unzip3 $ fmap (go ((k, n) : ps)) cs
a0 = acnt k n (fmap snd ps) d
paths = expand k $ fmap fst ps
in (a0:concat as, paths ++ concat aps, concat ms)
in (a0 : concat as, paths ++ concat aps, concat ms)
go ps (Account d n) =
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))]
, [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign))]
)
toPath = T.intercalate "/" . (atName t:) . reverse
toPath = T.intercalate "/" . (atName t :) . reverse
acnt k n ps = Entity k . AccountR n (toPath ps)
expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0:hs) [0..]
expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..]
sign = accountSign t
paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
paths2IDs = uncurry zip
paths2IDs =
uncurry zip
. first trimNames
. unzip
. L.sortOn fst
@ -237,22 +247,22 @@ trimNames = fmap fmt . trimAll 0
fmt [] = err "blank path"
fmt ys = T.intercalate "_" $ reverse ys
trimAll _ [] = []
trimAll i (y:ys) = case L.foldl' (matchPre i) (y, [], []) ys of
(a, [], bs) -> reverse $ trim i a:bs
(a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a:as)
trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
(a, [], bs) -> reverse $ trim i a : bs
(a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
matchPre i (y, ys, old) new = case (y !? i, new !? i) of
(Nothing, Just _) ->
case ys of
[] -> (new, [], trim i y:old)
[] -> (new, [], trim i y : old)
_ -> err "unsorted input"
(Just _, Nothing) -> err "unsorted input"
(Nothing, Nothing) -> err "duplicated inputs"
(Just a, Just b)
| a == b -> (new, y:ys, old)
| a == b -> (new, y : ys, old)
| otherwise ->
let next = case ys of
[] -> [trim i y]
_ -> trimAll (i + 1) (reverse $ y:ys)
_ -> trimAll (i + 1) (reverse $ y : ys)
in (new, [], reverse next ++ old)
trim i = take (i + 1)
err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
@ -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

View File

@ -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))
@ -56,18 +49,21 @@ lookupCurrency c = do
-- intervals
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
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')
<$> maybe id (take . fromIntegral) r [0..]
}
(lower, upper) =
takeWhile (<= upper) $
(`addFun` start) . (* b')
<$> maybe id (take . fromIntegral) r [0 ..]
where
start = maybe lower fromGregorian' s
b' = fromIntegral b
@ -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
@ -112,9 +111,9 @@ mdyPatternMatches :: (Natural -> Maybe String) -> Natural -> MDYPat -> Bool
mdyPatternMatches check x p = case p of
Single y -> errMaybe (check y) $ x == y
Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs
Repeat (RepeatPat { rpStart = s, rpBy = b, rpRepeats = r }) ->
errMaybe (check s)
$ s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) ->
errMaybe (check s) $
s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
where
errMaybe test rest = maybe rest err test
err msg = error $ show p ++ ": " ++ msg
@ -123,13 +122,18 @@ mdyPatternMatches check x p = case p of
-- budget
insertBudget :: MonadIO m => Budget -> MappingT m ()
insertBudget Budget { income = is, expenses = es } = do
insertBudget Budget {income = is, expenses = es} = do
mapM_ insertIncome is
mapM_ insertExpense es
-- TODO this hashes twice (not that it really matters)
whenHash :: Hashable a => MonadIO m => ConfigType -> a
-> (Key CommitR -> MappingT m ()) -> MappingT m ()
whenHash
:: Hashable a
=> MonadIO m
=> ConfigType
-> a
-> (Key CommitR -> MappingT m ())
-> MappingT m ()
whenHash t o f = do
let h = hash o
hs <- asks kmNewCommits
@ -137,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
@ -149,11 +155,13 @@ insertIncome i@Income { incCurrency = cur
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
forM_ (expandDatePat bounds dp) $ \day -> do
alloTx <- concat <$> mapM (allocationToTx from day) as
taxTx <- fmap (, Fixed) <$> mapM (taxToTx from day cur) ts
taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx
balanceIncome :: Income -> Either T.Text [BalAllocation]
balanceIncome Income { incGross = g
balanceIncome
Income
{ incGross = g
, incPretax = pre
, incTaxes = tax
, incPosttax = post
@ -164,7 +172,7 @@ balanceIncome Income { incGross = g
bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax)
mapAlloAmts :: (a -> b) -> Allocation a -> Allocation b
mapAlloAmts f a@Allocation { alloAmts = as } = a { alloAmts = fmap f <$> as }
mapAlloAmts f a@Allocation {alloAmts = as} = a {alloAmts = fmap f <$> as}
sumAllocations :: [BalAllocation] -> Rational
sumAllocations = sum . concatMap (fmap amtValue . alloAmts)
@ -177,44 +185,60 @@ 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
else Right $ mapAmts (empty {amtValue = s} :) nonmissing : bs
([], _) -> Left "need one blank amount to balance"
_ -> Left "multiple blank amounts present"
where
hasVal a@Allocation { alloAmts = xs } =
hasVal a@Allocation {alloAmts = xs} =
case partitionEithers $ fmap maybeAmt xs of
([], bs) -> Right a { alloAmts = bs }
(unbal, bs) -> Left (unbal, a { alloAmts = bs })
maybeAmt a@Amount { amtValue = Just v } = Right a { amtValue = v }
([], bs) -> Right a {alloAmts = bs}
(unbal, bs) -> Left (unbal, a {alloAmts = bs})
maybeAmt a@Amount {amtValue = Just v} = Right a {amtValue = v}
maybeAmt a = Left a
-- TODO lens reinvention
mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b
mapAmts f a@Allocation { alloAmts = xs } = a { alloAmts = f xs }
mapAmts f a@Allocation {alloAmts = xs} = a {alloAmts = f xs}
allocationToTx :: MonadIO m => AcntID -> Day -> BalAllocation
allocationToTx
:: MonadIO m
=> AcntID
-> Day
-> BalAllocation
-> MappingT m [(KeyTx, Bucket)]
allocationToTx from day Allocation { alloPath = to
allocationToTx
from
day
Allocation
{ alloPath = to
, alloBucket = b
, alloCurrency = cur
, alloAmts = as
} =
fmap (, b) <$> mapM (transferToTx day from to cur) as
fmap (,b) <$> mapM (transferToTx day from to cur) as
taxToTx :: MonadIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx
taxToTx from day cur Tax { taxAcnt = to, taxValue = v } =
taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
txPair day from to cur (dec2Rat v) ""
transferToTx :: MonadIO m => Day -> AcntID -> AcntID -> T.Text -> BalAmount
transferToTx
:: MonadIO m
=> Day
-> AcntID
-> AcntID
-> T.Text
-> BalAmount
-> MappingT m KeyTx
transferToTx day from to cur Amount { amtValue = v, amtDesc = d } =
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
txPair day from to cur v d
insertExpense :: MonadIO m => Expense -> MappingT m ()
insertExpense e@Expense { expFrom = from
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,39 +311,50 @@ insertImport i = whenHash CTImport i $ \c -> do
--------------------------------------------------------------------------------
-- low-level transaction stuff
txPair :: MonadIO m => Day -> AcntID -> AcntID -> T.Text -> Rational -> T.Text
txPair
:: MonadIO m
=> Day
-> AcntID
-> AcntID
-> T.Text
-> Rational
-> T.Text
-> MappingT m KeyTx
txPair day from to cur val desc = resolveTx tx
where
split a v = Split { sAcnt = a, sValue = v, sComment = "", sCurrency = cur }
tx = Tx { txDescr = desc
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
tx =
Tx
{ txDescr = desc
, txDate = day
, txTags = []
, txSplits = [split from (-val), split to val]
}
resolveTx :: MonadIO m => BalTx -> MappingT m KeyTx
resolveTx t@Tx { txSplits = ss } = do
resolveTx t@Tx {txSplits = ss} = do
rs <- catMaybes <$> mapM resolveSplit ss
return $ t { txSplits = rs }
return $ t {txSplits = rs}
resolveSplit :: MonadIO m => BalSplit -> MappingT m (Maybe KeySplit)
resolveSplit s@Split { sAcnt = p, sCurrency = c, sValue = v } = do
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
aid <- lookupAccountKey p
cid <- lookupCurrency c
sign <- lookupAccountSign p
-- TODO correct sign here?
-- TODO lenses would be nice here
return $ case (aid, cid, sign) of
(Just aid', Just cid', Just sign')
-> Just $ s { sAcnt = aid'
(Just aid', Just cid', Just sign') ->
Just $
s
{ sAcnt = aid'
, sCurrency = cid'
, sValue = v * fromIntegral (sign2Int sign')
}
_ -> Nothing
insertTxBucket :: MonadIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m ()
insertTxBucket b c Tx { txDate = d, txDescr = e, txSplits = ss } = do
insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do
k <- insert $ TransactionR c d e (fmap (T.pack . show) b)
mapM_ (insertSplit k) ss
@ -312,5 +362,5 @@ insertTx :: MonadIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
insertTx = insertTxBucket Nothing
insertSplit :: MonadIO m => Key TransactionR -> KeySplit -> SqlPersistT m ()
insertSplit t Split { sAcnt = aid, sCurrency = cid, sValue = v, sComment = c } = do
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
insert_ $ SplitR t cid aid c v

View File

@ -3,38 +3,29 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module Internal.Statement
( readImport
) where
module Internal.Statement (
readImport,
) where
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Bifunctor
import qualified Data.ByteString.Lazy as BL
import Data.Csv
import Data.Either
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe
import Data.Ord
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time
import qualified Data.Vector as V
import Internal.Database.Model
import Internal.Types
import Internal.Utils
import Numeric.Natural
import System.FilePath
import 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
@ -55,50 +51,55 @@ readImport_ n delim tns p = do
Left m -> liftIO $ putStrLn m >> return []
Right (_, v) -> return $ catMaybes $ V.toList v
where
opts = defaultDecodeOptions { decDelimiter = fromIntegral delim }
opts = defaultDecodeOptions{decDelimiter = fromIntegral delim}
skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
-- TODO handle this better, this maybe thing is a hack to skip lines with
-- blank dates but will likely want to make this more flexible
parseTxRecord :: TxOpts -> NamedRecord -> Parser (Maybe TxRecord)
parseTxRecord TxOpts {..} r = do
d <- r .: TE.encodeUtf8 toDate
parseTxRecord TxOpts{..} r = do
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]
@ -117,37 +118,38 @@ zipperSlice :: (a -> b -> Ordering) -> b -> Zipped a -> Either (Zipped a) (Unzip
zipperSlice f x = go
where
go z@(Zipped _ []) = Left z
go z@(Zipped bs (a:as)) = case f a x of
GT -> go $ Zipped (a:bs) as
go z@(Zipped bs (a : as)) = case f a x of
GT -> go $ Zipped (a : bs) as
EQ -> Right $ goEq (Unzipped bs [a] as)
LT -> Left z
goEq z@(Unzipped _ _ []) = z
goEq z@(Unzipped bs cs (a:as)) = case f a x of
GT -> goEq $ Unzipped (a:bs) cs as
EQ -> goEq $ Unzipped bs (a:cs) as
goEq z@(Unzipped bs cs (a : as)) = case f a x of
GT -> goEq $ Unzipped (a : bs) cs as
EQ -> goEq $ Unzipped bs (a : cs) as
LT -> z
zipperMatch :: Unzipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
zipperMatch (Unzipped bs cs as) x = go [] cs
where
go _ [] = (Zipped bs $ cs ++ as, Nothing)
go prev (m:ms) = case matches m x of
Nothing -> go (m:prev) ms
res@(Just _) -> let ps = reverse prev
ms' = maybe ms (:ms) (matchDec m) in
(Zipped bs $ ps ++ ms' ++ as, res)
go prev (m : ms) = case matches m x of
Nothing -> go (m : prev) ms
res@(Just _) ->
let ps = reverse prev
ms' = maybe ms (: ms) (matchDec m)
in (Zipped bs $ ps ++ ms' ++ as, res)
zipperMatch' :: Zipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
zipperMatch' z x = go z
where
go (Zipped bs (a:as)) = case matches a x of
Nothing -> go (Zipped (a:bs) as)
res -> (Zipped (maybe bs (:bs) $ matchDec a) as, res)
go (Zipped bs (a : as)) = case matches a x of
Nothing -> go (Zipped (a : bs) as)
res -> (Zipped (maybe bs (: bs) $ matchDec a) as, res)
go z' = (z', Nothing)
matchDec :: Match -> Maybe Match
matchDec m@Match { mTimes = t } =
if t' == Just 0 then Nothing else Just $ m { mTimes = t' }
matchDec m@Match{mTimes = t} =
if t' == Just 0 then Nothing else Just $ m{mTimes = t'}
where
t' = fmap pred t
@ -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
@ -171,13 +174,13 @@ matchDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
matchDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z)
go (matched, unmatched, z) (r:rs) = case zipperSlice findDate r z of
Left res -> go (matched, r:unmatched, res) rs
go (matched, unmatched, z) (r : rs) = case zipperSlice findDate r z of
Left res -> go (matched, r : unmatched, res) rs
Right res ->
let (z', p) = zipperMatch res r
(m, u) = case p of
Just p' -> (p':matched, unmatched)
Nothing -> (matched, r:unmatched)
Just p' -> (p' : matched, unmatched)
Nothing -> (matched, r : unmatched)
in go (m, u, z') rs
findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
@ -185,32 +188,33 @@ matchNonDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
matchNonDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z)
go (matched, unmatched, z) (r:rs) =
go (matched, unmatched, z) (r : rs) =
let (z', res) = zipperMatch' z r
(m, u) = case res of
Just x -> (x:matched, unmatched)
Nothing -> (matched, r:unmatched)
Just x -> (x : matched, unmatched)
Nothing -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs
balanceTx :: RawTx -> Either T.Text BalTx
balanceTx t@Tx { txSplits = ss } = do
balanceTx t@Tx{txSplits = ss} = do
bs <- balanceSplits ss
return $ t { txSplits = bs }
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
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
bal cur rss
| length rss < 2 = Left $ T.append "Need at least two splits to balance: " cur
| otherwise = case partitionEithers $ fmap hasValue rss of
([noVal], val) -> Right $ noVal { sValue = foldr (\s x -> x - sValue s) 0 val } : val
([noVal], val) -> Right $ noVal{sValue = foldr (\s x -> x - sValue s) 0 val} : val
([], val) -> Right val
_ -> Left $ T.append "Exactly one split must be blank: " cur
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
groupByKey = M.toList . M.fromListWith (++) . fmap (second (:[]))
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))

View File

@ -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_
@ -117,9 +113,10 @@ type ConfigF = Config_ AccountRootF
type Config = Config_ AccountRoot
unfix :: ConfigF -> Config
unfix c@Config_ { accounts = a } = c { accounts = a' }
unfix c@Config_{accounts = a} = c{accounts = a'}
where
a' = AccountRoot_
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
@ -166,15 +164,16 @@ deriving instance Hashable GregorianM
-- Dhall.TH rearranges my fields :(
instance Ord Gregorian where
compare
Gregorian { gYear = y, gMonth = m, gDay = d}
Gregorian { gYear = y', gMonth = m', gDay = d'} = compare y y'
Gregorian{gYear = y, gMonth = m, gDay = d}
Gregorian{gYear = y', gMonth = m', gDay = d'} =
compare y y'
<> compare m m'
<> compare d d'
instance Ord GregorianM where
compare
GregorianM { gmYear = y, gmMonth = m}
GregorianM { gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
GregorianM{gmYear = y, gmMonth = m}
GregorianM{gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
deriving instance Eq ModPat
deriving instance Hashable ModPat
@ -186,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)

View File

@ -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
@ -78,26 +78,30 @@ valMatches MatchVal {..} x = checkMaybe (s ==) mvSign
s = signum x >= 0
evalSplit :: TxRecord -> ExpSplit -> RawSplit
evalSplit r s@Split { sAcnt = a, sValue = v, sCurrency = c } =
s { sAcnt = evalAcnt r a
evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
s
{ sAcnt = evalAcnt r a
, sValue = evalExp r =<< v
, sCurrency = evalCurrency r c }
, sCurrency = evalCurrency r c
}
evalAcnt :: TxRecord -> SplitAcnt -> T.Text
evalAcnt TxRecord { trOther = o } s = case s of
evalAcnt TxRecord {trOther = o} s = case s of
ConstT p -> p
LookupT f -> read $ T.unpack $ lookupField f o
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
evalCurrency :: TxRecord -> SplitCur -> T.Text
evalCurrency TxRecord { trOther = o } s = case s of
evalCurrency TxRecord {trOther = o} s = case s of
ConstT p -> p
LookupT f -> lookupField f o
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
, 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
@ -193,7 +209,7 @@ readRational s = case T.splitOn "." s of
-- TODO smells like a lens
mapTxSplits :: (a -> b) -> Tx a -> Tx b
mapTxSplits f t@Tx { txSplits = ss } = t { txSplits = fmap f ss }
mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds
boundsFromGregorian = bimap fromGregorian' fromGregorian'
@ -208,7 +224,7 @@ inMaybeBounds :: MaybeBounds -> Day -> Bool
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
intervalMaybeBounds :: Interval -> MaybeBounds
intervalMaybeBounds Interval { intStart = s, intEnd = e } =
intervalMaybeBounds Interval {intStart = s, intEnd = e} =
(fromGregorian' <$> s, fromGregorian' <$> e)
resolveBounds :: MaybeBounds -> IO Bounds
@ -223,10 +239,10 @@ fmtRational :: Natural -> Rational -> T.Text
fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
where
s = if x >= 0 then "" else "-"
x'@(n:%d) = abs x
x'@(n :% d) = abs x
p = 10 ^ precision
n' = toInteger $ div n d
d' = toInteger $ (\(a:%b) -> div a b) ((x' - fromIntegral n') * p)
n' = div n d
d' = (\(a :% b) -> div a b) ((x' - fromIntegral n') * p)
txt = T.pack . show
pad i c z = T.append (T.replicate (i - T.length z) c) z

View File

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