ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'update_dhall_types'

This commit is contained in:
Nathan Dwarshuis 2023-05-16 23:20:54 -04:00
parent 8c5a68a4b4 b2fdc8d74c
commit 48adbccdcc
13 changed files with 2322 additions and 1287 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
app/Main.hs
View File

@ -2,8 +2,12 @@
module Main (main) where
import Control.Monad.Except
import Control.Monad.IO.Rerunnable
import Control.Monad.Logger
import Control.Monad.Reader
import qualified Data.Text.IO as TI
import Database.Persist.Monad
import Internal.Config
import Internal.Database.Ops
import Internal.Insert
@ -103,7 +107,7 @@ sync =
parse :: Options -> IO ()
parse (Options c Reset) = do
config <- readConfig c
migrate_ (sqlConfig config) nukeTables
runDB (sqlConfig config) nukeTables
parse (Options c DumpAccounts) = runDumpAccounts c
parse (Options c DumpAccountKeys) = runDumpAccountKeys c
parse (Options c DumpCurrencies) = runDumpCurrencies c
@ -155,19 +159,31 @@ runDumpAccountKeys c = do
t3 (_, _, x) = x
double x = (x, x)
runSync :: MonadUnliftIO m => FilePath -> m ()
runSync :: FilePath -> IO ()
runSync c = do
config <- readConfig c
handle err $ migrate_ (sqlConfig config) $ do
res <- getDBState config
case res of
Left es -> throwIO $ InsertException es
Right s -> do
let run = mapReaderT $ flip runReaderT (s $ takeDirectory c)
es1 <- concat <$> mapM (run . insertBudget) (budget config)
es2 <- run $ insertStatements config
let es = es1 ++ es2
unless (null es) $ throwIO $ InsertException es
let (hTs, hSs) = splitHistory $ statements config
pool <- runNoLoggingT $ mkPool $ sqlConfig config
handle err $ do
-- _ <- askLoggerIO
-- get the current DB state
s <- runSqlQueryT pool $ do
runMigration migrateAll
fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
-- read desired statements from disk
bSs <- flip runReaderT s $ catMaybes <$> mapM readHistStmt hSs
-- update the DB
runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do
let hTransRes = mapErrors insertHistTransfer hTs
let bgtRes = mapErrors insertBudget $ budget config
updateDBState -- TODO this will only work if foreign keys are deferred
res <- runExceptT $ do
mapM_ (uncurry insertHistStmt) bSs
combineError hTransRes bgtRes $ \_ _ -> ()
rerunnableIO $ fromEither res
where
err (InsertException es) = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es

3
budget.cabal
View File

@ -29,6 +29,7 @@ library
Internal.Database.Ops
Internal.Insert
Internal.Statement
Internal.TH
Internal.Types
Internal.Utils
other-modules:
@ -88,6 +89,7 @@ library
, mtl
, optparse-applicative
, persistent >=2.13.3.1
, persistent-mtl >=0.3.0.0
, persistent-sqlite
, recursion-schemes
, regex-tdfa
@ -157,6 +159,7 @@ executable pwncash
, mtl
, optparse-applicative
, persistent >=2.13.3.1
, persistent-mtl >=0.3.0.0
, persistent-sqlite
, recursion-schemes
, regex-tdfa

50
dhall/Accounts.dhall
View File

@ -1,50 +0,0 @@
let List/map =
https://prelude.dhall-lang.org/v21.1.0/List/map
sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680
let AccountTree
: Type
= forall (a : Type) ->
forall ( Fix
: < AccountF : { _1 : Text, _2 : Text }
| PlaceholderF : { _1 : Text, _2 : Text, _3 : List a }
> ->
a
) ->
a
let AccountTreeF =
\(a : Type) ->
< AccountF : { _1 : Text, _2 : Text }
| PlaceholderF : { _1 : Text, _2 : Text, _3 : List a }
>
let Account
: Text -> Text -> AccountTree
= \(desc : Text) ->
\(name : Text) ->
\(a : Type) ->
let f = AccountTreeF a
in \(Fix : f -> a) -> Fix (f.AccountF { _1 = desc, _2 = name })
let Placeholder
: Text -> Text -> List AccountTree -> AccountTree
= \(desc : Text) ->
\(name : Text) ->
\(children : List AccountTree) ->
\(a : Type) ->
let f = AccountTreeF a
in \(Fix : f -> a) ->
let apply = \(x : AccountTree) -> x a Fix
in Fix
( f.PlaceholderF
{ _1 = desc
, _2 = name
, _3 = List/map AccountTree a apply children
}
)
in { Account, Placeholder }

1135
dhall/Types.dhall
View File

File diff suppressed because it is too large Load Diff

91
dhall/common.dhall
View File

@ -4,29 +4,16 @@ let List/map =
let T = ./Types.dhall
let dec =
\(s : Bool) ->
\(w : Natural) ->
\(d : Natural) ->
\(p : Natural) ->
{ whole = w, decimal = d, precision = p, sign = s } : T.Decimal
let dec2 = \(s : Bool) -> \(w : Natural) -> \(d : Natural) -> dec s w d 2
let d = dec2 True
let d_ = dec2 False
let nullSplit =
\(a : T.SplitAcnt) ->
\(c : T.SplitCur) ->
T.ExpSplit::{ sAcnt = a, sCurrency = c, sTags = [] : List T.TagID }
\(a : T.EntryAcntGetter) ->
\(c : T.EntryCurGetter) ->
T.EntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
let nullOpts = T.TxOpts::{=}
let nullVal = T.MatchVal::{=}
let nullVal = T.ValMatcher::{=}
let nullMatch = T.Match::{=}
let nullMatch = T.StatementParser::{=}
let nullCron = T.CronPat::{=}
@ -41,20 +28,20 @@ let cron1 =
\(d : Natural) ->
T.DatePat.Cron
( nullCron
// { cronYear = Some (T.MDYPat.Single y)
, cronMonth = Some (T.MDYPat.Single m)
, cronDay = Some (T.MDYPat.Single d)
// { cpYear = Some (T.MDYPat.Single y)
, cpMonth = Some (T.MDYPat.Single m)
, cpDay = Some (T.MDYPat.Single d)
}
)
let matchInf_ = nullMatch
let matchInf = \(x : T.ToTx) -> nullMatch // { mTx = Some x }
let matchInf = \(x : T.TxGetter) -> nullMatch // { spTx = Some x }
let matchN_ = \(n : Natural) -> nullMatch // { mTimes = Some n }
let matchN_ = \(n : Natural) -> nullMatch // { spTimes = Some n }
let matchN =
\(n : Natural) -> \(x : T.ToTx) -> matchInf x // { mTimes = Some n }
\(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { spTimes = Some n }
let match1_ = matchN_ 1
@ -68,61 +55,63 @@ let greg =
\(d : Natural) ->
{ gYear = y, gMonth = m, gDay = d }
let mY = \(y : Natural) -> T.MatchDate.On (T.MatchYMD.Y y)
let mY = \(y : Natural) -> T.DateMatcher.On (T.YMDMatcher.Y y)
let mYM =
\(y : Natural) ->
\(m : Natural) ->
T.MatchDate.On (T.MatchYMD.YM (gregM y m))
T.DateMatcher.On (T.YMDMatcher.YM (gregM y m))
let mYMD =
\(y : Natural) ->
\(m : Natural) ->
\(d : Natural) ->
T.MatchDate.On (T.MatchYMD.YMD (greg y m d))
T.DateMatcher.On (T.YMDMatcher.YMD (greg y m d))
let mRngY =
\(y : Natural) ->
\(r : Natural) ->
T.MatchDate.In { _1 = T.MatchYMD.Y y, _2 = r }
T.DateMatcher.In { _1 = T.YMDMatcher.Y y, _2 = r }
let mRngYM =
\(y : Natural) ->
\(m : Natural) ->
\(r : Natural) ->
T.MatchDate.In { _1 = T.MatchYMD.YM (gregM y m), _2 = r }
T.DateMatcher.In { _1 = T.YMDMatcher.YM (gregM y m), _2 = r }
let mRngYMD =
\(y : Natural) ->
\(m : Natural) ->
\(d : Natural) ->
\(r : Natural) ->
T.MatchDate.In { _1 = T.MatchYMD.YMD (greg y m d), _2 = r }
T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
let PartSplit = { _1 : T.AcntID, _2 : T.Decimal, _3 : Text }
let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text }
let partN =
\(c : T.SplitCur) ->
\(a : T.SplitAcnt) ->
\(c : T.EntryCurGetter) ->
\(a : T.EntryAcntGetter) ->
\(comment : Text) ->
\(ss : List PartSplit) ->
let toSplit =
\(x : PartSplit) ->
nullSplit (T.SplitAcnt.ConstT x._1) c
// { sValue = Some (T.SplitNum.ConstN x._2), sComment = x._3 }
nullSplit (T.EntryAcntGetter.ConstT x._1) c
// { eValue = Some (T.EntryNumGetter.ConstN x._2)
, eComment = x._3
}
in [ nullSplit a c // { sComment = comment } ]
# List/map PartSplit T.ExpSplit.Type toSplit ss
in [ nullSplit a c // { eComment = comment } ]
# List/map PartSplit T.EntryGetter.Type toSplit ss
let part1 =
\(c : T.SplitCur) ->
\(a : T.SplitAcnt) ->
\(c : T.EntryCurGetter) ->
\(a : T.EntryAcntGetter) ->
\(comment : Text) ->
partN c a comment ([] : List PartSplit)
let part1_ =
\(c : T.SplitCur) ->
\(a : T.SplitAcnt) ->
\(c : T.EntryCurGetter) ->
\(a : T.EntryAcntGetter) ->
partN c a "" ([] : List PartSplit)
let addDay =
@ -130,21 +119,21 @@ let addDay =
\(d : Natural) ->
{ gYear = x.gmYear, gMonth = x.gmMonth, gDay = d }
let mvP = nullVal // { mvSign = Some True }
let mvP = nullVal // { vmSign = Some True }
let mvN = nullVal // { mvSign = Some False }
let mvN = nullVal // { vmSign = Some False }
let mvNum = \(x : Natural) -> nullVal // { mvNum = Some x }
let mvNum = \(x : Natural) -> nullVal // { vmNum = Some x }
let mvDen = \(x : Natural) -> nullVal // { mvDen = Some x }
let mvDen = \(x : Natural) -> nullVal // { vmDen = Some x }
let mvNumP = \(x : Natural) -> mvP // { mvNum = Some x }
let mvNumP = \(x : Natural) -> mvP // { vmNum = Some x }
let mvNumN = \(x : Natural) -> mvN // { mvNum = Some x }
let mvNumN = \(x : Natural) -> mvN // { vmNum = Some x }
let mvDenP = \(x : Natural) -> mvP // { mvDen = Some x }
let mvDenP = \(x : Natural) -> mvP // { vmDen = Some x }
let mvDenN = \(x : Natural) -> mvN // { mvDen = Some x }
let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }
in { nullSplit
, nullMatch
@ -182,9 +171,5 @@ in { nullSplit
, mvDenP
, mvDenN
, PartSplit
, d
, d_
, dec
, dec2
}
/\ T

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

@ -1,21 +1,26 @@
module Internal.Database.Ops
( migrate_
( runDB
, nukeTables
, updateHashes
, updateDBState
, getDBState
, tree2Records
, flattenAcntRoot
, paths2IDs
, mkPool
)
where
import Conduit
import Control.Monad.Except
import Control.Monad.Logger
import Data.Hashable
import Database.Esqueleto.Experimental
import Database.Persist.Sql hiding (delete, (==.), (||.))
import Database.Persist.Sqlite hiding (delete, (==.), (||.))
import Database.Sqlite hiding (Config)
import Database.Esqueleto.Experimental ((==.), (^.))
import qualified Database.Esqueleto.Experimental as E
import Database.Esqueleto.Internal.Internal (SqlSelect)
import Database.Persist.Monad
-- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.))
import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.))
import GHC.Err
import Internal.Types
import Internal.Utils
@ -26,31 +31,27 @@ import qualified RIO.Map as M
import qualified RIO.NonEmpty as N
import qualified RIO.Text as T
migrate_
runDB
:: MonadUnliftIO m
=> SqlConfig
-> SqlPersistT (ResourceT (NoLoggingT m)) ()
-> m ()
migrate_ c more =
runNoLoggingT $
runResourceT $
withSqlConn
(openConnection c)
( \backend ->
flip runSqlConn backend $ do
_ <- askLoggerIO
-> SqlQueryT (NoLoggingT m) a
-> m a
runDB c more =
runNoLoggingT $ do
pool <- mkPool c
runSqlQueryT pool $ do
_ <- lift askLoggerIO
runMigration migrateAll
more
)
openConnection :: MonadUnliftIO m => SqlConfig -> LogFunc -> m SqlBackend
openConnection c logfn = case c of
Sqlite p -> liftIO $ do
conn <- open p
wrapConnection conn logfn
mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool
mkPool c = case c of
Sqlite p -> createSqlitePool p 10
-- conn <- open p
-- wrapConnection conn logfn
Postgres -> error "postgres not implemented"
nukeTables :: MonadUnliftIO m => SqlPersistT m ()
nukeTables :: MonadSqlQuery m => m ()
nukeTables = do
deleteWhere ([] :: [Filter CommitR])
deleteWhere ([] :: [Filter CurrencyR])
@ -98,8 +99,8 @@ hashConfig
} = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
where
(ms, ps) = partitionEithers $ fmap go ss
go (StmtManual x) = Left x
go (StmtImport x) = Right x
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
setDiff :: Eq a => [a] -> [a] -> ([a], [a])
-- setDiff = setDiff' (==)
@ -118,99 +119,67 @@ setDiff as bs = (as \\ bs, bs \\ as)
-- | f a b = Just bs
-- | otherwise = inB a bs
getDBHashes :: MonadUnliftIO m => SqlPersistT m [Int]
getDBHashes :: MonadSqlQuery m => m [Int]
getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
nukeDBHash :: MonadUnliftIO m => Int -> SqlPersistT m ()
nukeDBHash h = delete $ do
c <- from table
where_ (c ^. CommitRHash ==. val h)
nukeDBHash :: MonadSqlQuery m => Int -> m ()
nukeDBHash h = deleteE $ do
c <- E.from E.table
E.where_ (c ^. CommitRHash ==. E.val h)
nukeDBHashes :: MonadUnliftIO m => [Int] -> SqlPersistT m ()
nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
nukeDBHashes = mapM_ nukeDBHash
getConfigHashes :: MonadUnliftIO m => Config -> SqlPersistT m ([Int], [Int])
getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int])
getConfigHashes c = do
let ch = hashConfig c
dh <- getDBHashes
return $ setDiff dh ch
updateHashes :: MonadUnliftIO m => Config -> SqlPersistT m [Int]
updateHashes c = do
(del, new) <- getConfigHashes c
nukeDBHashes del
return new
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
dumpTbl = selectE $ E.from E.table
dumpTbl :: (PersistEntity r, MonadUnliftIO m) => SqlPersistT m [Entity r]
dumpTbl = select $ from table
deleteAccount :: MonadUnliftIO m => Entity AccountR -> SqlPersistT m ()
deleteAccount e = delete $ do
c <- from $ table @AccountR
where_ (c ^. AccountRId ==. val k)
deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
deleteAccount e = deleteE $ do
c <- E.from $ E.table @AccountR
E.where_ (c ^. AccountRId ==. E.val k)
where
k = entityKey e
deleteCurrency :: MonadUnliftIO m => Entity CurrencyR -> SqlPersistT m ()
deleteCurrency e = delete $ do
c <- from $ table @CurrencyR
where_ (c ^. CurrencyRId ==. val k)
deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
deleteCurrency e = deleteE $ do
c <- E.from $ E.table @CurrencyR
E.where_ (c ^. CurrencyRId ==. E.val k)
where
k = entityKey e
deleteTag :: MonadUnliftIO m => Entity TagR -> SqlPersistT m ()
deleteTag e = delete $ do
c <- from $ table @TagR
where_ (c ^. TagRId ==. val k)
deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
deleteTag e = deleteE $ do
c <- E.from $ E.table @TagR
E.where_ (c ^. TagRId ==. E.val k)
where
k = entityKey e
updateAccounts :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap
updateAccounts ar = do
let (acnts, paths, acntMap) = indexAcntRoot ar
acnts' <- dumpTbl
let (toIns, toDel) = setDiff acnts acnts'
deleteWhere ([] :: [Filter AccountPathR])
mapM_ deleteAccount toDel
-- liftIO $ mapM_ print toDel
mapM_ insertFull toIns
mapM_ insert paths
return acntMap
-- TODO slip-n-slide code...
insertFull
:: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
:: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
=> Entity r
-> ReaderT b m ()
-> m ()
insertFull (Entity k v) = insertKey k v
updateCurrencies :: MonadUnliftIO m => [Currency] -> SqlPersistT m CurrencyMap
updateCurrencies cs = do
let curs = fmap currency2Record cs
curs' <- select $ from $ table @CurrencyR
let (toIns, toDel) = setDiff curs curs'
mapM_ deleteCurrency toDel
mapM_ insertFull toIns
return $ currencyMap curs
currency2Record :: Currency -> Entity CurrencyR
currency2Record c@Currency {curSymbol, curFullname} =
Entity (toKey c) $ CurrencyR curSymbol curFullname
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
currencyMap :: [Entity CurrencyR] -> CurrencyMap
currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
updateTags :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap
updateTags cs = do
let tags = fmap toRecord cs
tags' <- select $ from $ table @TagR
let (toIns, toDel) = setDiff tags tags'
mapM_ deleteTag toDel
mapM_ insertFull toIns
return $ tagMap tags
where
toRecord t@(Tag {tagID, tagDesc}) = Entity (toKey t) $ TagR tagID tagDesc
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
currencyMap =
M.fromList
. fmap
( \e ->
( currencyRSymbol $ entityVal e
, (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e)
)
)
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
toKey = toSqlKey . fromIntegral . hash
@ -317,26 +286,81 @@ indexAcntRoot r =
(ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
getDBState
:: MonadUnliftIO m
:: (MonadInsertError m, MonadSqlQuery m)
=> Config
-> SqlPersistT m (EitherErrs (FilePath -> DBState))
-> m (FilePath -> DBState)
getDBState c = do
am <- updateAccounts $ accounts c
cm <- updateCurrencies $ currencies c
ts <- updateTags $ tags c
hs <- updateHashes c
(del, new) <- getConfigHashes c
-- TODO not sure how I feel about this, probably will change this struct alot
-- in the future so whatever...for now
return $ concatEither2 bi si $ \b s f ->
combineError bi si $ \b s f ->
-- TODO this can be cleaned up, half of it is meant to be queried when
-- determining how to insert budgets/history and the rest is just
-- holdover data to delete upon successful insertion
DBState
{ kmCurrency = cm
{ kmCurrency = currencyMap cs
, kmAccount = am
, kmBudgetInterval = b
, kmStatementInterval = s
, kmNewCommits = hs
, kmNewCommits = new
, kmOldCommits = del
, kmConfigDir = f
, kmTag = ts
, kmTag = tagMap ts
, kmTagAll = ts
, kmAcntPaths = paths
, kmAcntsOld = acnts
, kmCurrenciesOld = cs
}
where
bi = resolveBounds $ budgetInterval $ global c
si = resolveBounds $ statementInterval $ global c
bi = liftExcept $ resolveBounds $ budgetInterval $ global c
si = liftExcept $ resolveBounds $ statementInterval $ global c
(acnts, paths, am) = indexAcntRoot $ accounts c
cs = currency2Record <$> currencies c
ts = toRecord <$> tags c
toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
updateHashes :: (MonadFinance m, MonadSqlQuery m) => m ()
updateHashes = do
old <- askDBState kmOldCommits
nukeDBHashes old
updateTags :: (MonadFinance m, MonadSqlQuery m) => m ()
updateTags = do
tags <- askDBState kmTagAll
tags' <- selectE $ E.from $ E.table @TagR
let (toIns, toDel) = setDiff tags tags'
mapM_ deleteTag toDel
mapM_ insertFull toIns
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m ()
updateAccounts = do
acnts <- askDBState kmAcntsOld
paths <- askDBState kmAcntPaths
acnts' <- dumpTbl
let (toIns, toDel) = setDiff acnts acnts'
deleteWhere ([] :: [Filter AccountPathR])
mapM_ deleteAccount toDel
mapM_ insertFull toIns
mapM_ insert paths
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m ()
updateCurrencies = do
curs <- askDBState kmCurrenciesOld
curs' <- selectE $ E.from $ E.table @CurrencyR
let (toIns, toDel) = setDiff curs curs'
mapM_ deleteCurrency toDel
mapM_ insertFull toIns
updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
updateDBState = do
updateHashes
updateTags
updateAccounts
updateCurrencies
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)

926
lib/Internal/Insert.hs
View File

File diff suppressed because it is too large Load Diff

115
lib/Internal/Statement.hs
View File

@ -5,6 +5,8 @@ module Internal.Statement
)
where
import Control.Monad.Error.Class
import Control.Monad.Except
import Data.Csv
import Internal.Types
import Internal.Utils
@ -18,32 +20,33 @@ import RIO.Time
import qualified RIO.Vector as V
-- TODO this probably won't scale well (pipes?)
readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx])
readImport Import {..} = do
let ores = plural $ compileOptions impTxOpts
let cres = concatEithersL $ compileMatch <$> impMatches
case concatEithers2 ores cres (,) of
Right (compiledOptions, compiledMatches) -> do
ires <- mapM (readImport_ impSkipLines impDelim compiledOptions) impPaths
case concatEitherL ires of
Right records -> return $ matchRecords compiledMatches $ L.sort $ concat records
Left es -> return $ Left es
Left es -> return $ Left es
readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
readImport Statement {..} = do
let ores = compileOptions stmtTxOpts
let cres = combineErrors $ compileMatch <$> stmtParsers
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
m <- askDBState kmCurrency
fromEither $
flip runReader m $
runExceptT $
matchRecords compiledMatches records
readImport_
:: MonadFinance m
:: (MonadUnliftIO m, MonadFinance m)
=> Natural
-> Word
-> TxOptsRe
-> FilePath
-> m (EitherErr [TxRecord])
-> m [TxRecord]
readImport_ n delim tns p = do
dir <- askDBState kmConfigDir
bs <- liftIO $ BL.readFile $ dir </> p
res <- tryIO $ BL.readFile $ dir </> p
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
Left m -> return $ Left $ ParseError $ T.pack m
Right (_, v) -> return $ Right $ catMaybes $ V.toList v
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
Right (_, v) -> return $ catMaybes $ V.toList v
where
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
@ -62,27 +65,25 @@ parseTxRecord p TxOpts {..} r = do
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os p
matchRecords :: [MatchRe] -> [TxRecord] -> EitherErrs [BalTx]
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of
(ms_, [], []) -> do
-- TODO record number of times each match hits for debugging
matched_ <- first (: []) $ mapM balanceTx ms_
Right matched_
(_, us, ns) -> Left [StatementError us ns]
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
matchPriorities :: [MatchRe] -> [MatchGroup]
matchPriorities =
fmap matchToGroup
. L.groupBy (\a b -> mPriority a == mPriority b)
. L.sortOn (Down . mPriority)
. L.groupBy (\a b -> spPriority a == spPriority b)
. L.sortOn (Down . spPriority)
matchToGroup :: [MatchRe] -> MatchGroup
matchToGroup ms =
uncurry MatchGroup $
first (L.sortOn mDate) $
L.partition (isJust . mDate) ms
first (L.sortOn spDate) $
L.partition (isJust . spDate) ms
-- TDOO could use a better struct to flatten the maybe date subtype
data MatchGroup = MatchGroup
@ -124,10 +125,13 @@ zipperSlice f x = go
EQ -> goEq $ Unzipped bs (a : cs) as
LT -> z
zipperMatch :: Unzipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx)
zipperMatch
:: Unzipped MatchRe
-> TxRecord
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
zipperMatch (Unzipped bs cs as) x = go [] cs
where
go _ [] = Right (Zipped bs $ cs ++ as, MatchFail)
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
go prev (m : ms) = do
res <- matches m x
case res of
@ -135,25 +139,30 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
skipOrPass ->
let ps = reverse prev
ms' = maybe ms (: ms) (matchDec m)
in Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
zipperMatch' :: Zipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx)
-- TODO all this unpacking left/error crap is annoying
zipperMatch'
:: Zipped MatchRe
-> TxRecord
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
zipperMatch' z x = go z
where
go (Zipped bs (a : as)) = do
res <- matches a x
case res of
MatchFail -> go (Zipped (a : bs) as)
skipOrPass -> Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
go z' = Right (z', MatchFail)
skipOrPass ->
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
go z' = return (z', MatchFail)
matchDec :: MatchRe -> Maybe MatchRe
matchDec m = case mTimes m of
matchDec m = case spTimes m of
Just 1 -> Nothing
Just n -> Just $ m {mTimes = Just $ n - 1}
Just n -> Just $ m {spTimes = Just $ n - 1}
Nothing -> Just m
matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchAll = go ([], [])
where
go (matched, unused) gs rs = case (gs, rs) of
@ -163,17 +172,17 @@ matchAll = go ([], [])
(ts, unmatched, us) <- matchGroup g rs
go (ts ++ matched, us ++ unused) gs' unmatched
matchGroup :: MatchGroup -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
(md, rest, ud) <- matchDates ds rs
(mn, unmatched, un) <- matchNonDates ns rest
return (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
matchDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
Right
return
( catMaybes matched
, reverse unmatched
, recoverZipper z
@ -184,17 +193,17 @@ matchDates ms = go ([], [], initZipper ms)
Right unzipped -> do
(z', res) <- zipperMatch unzipped r
let (m, u) = case res of
MatchPass p -> (Just p : matched, unmatched)
(MatchPass p) -> (Just p : matched, unmatched)
MatchSkip -> (Nothing : matched, unmatched)
MatchFail -> (matched, r : unmatched)
go (m, u, z') rs
findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
matchNonDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchNonDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
Right
return
( catMaybes matched
, reverse unmatched
, recoverZipper z
@ -207,26 +216,26 @@ matchNonDates ms = go ([], [], initZipper ms)
MatchFail -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs
balanceTx :: RawTx -> EitherErr BalTx
balanceTx :: RawTx -> InsertExcept BalTx
balanceTx t@Tx {txSplits = ss} = do
bs <- balanceSplits ss
return $ t {txSplits = bs}
balanceSplits :: [RawSplit] -> EitherErr [BalSplit]
balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
balanceSplits ss =
fmap concat
<$> mapM (uncurry bal)
$ groupByKey
$ fmap (\s -> (sCurrency s, s)) ss
$ fmap (\s -> (eCurrency s, s)) ss
where
hasValue s@(Split {sValue = Just v}) = Right s {sValue = v}
hasValue s = Left s
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
haeValue s = Left s
bal cur rss
| length rss < 2 = Left $ BalanceError TooFewSplits cur rss
| otherwise = case partitionEithers $ fmap hasValue rss of
([noVal], val) -> Right $ noVal {sValue = foldr (\s x -> x - sValue s) 0 val} : val
([], val) -> Right val
_ -> Left $ BalanceError NotOneBlank cur rss
| length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits cur rss]
| otherwise = case partitionEithers $ fmap haeValue rss of
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
([], val) -> return val
_ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))

12
lib/Internal/TH.hs Normal file
View File

@ -0,0 +1,12 @@
module Internal.TH where
import Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName)
import RIO
deriveProduct :: [String] -> [String] -> Q [Dec]
deriveProduct cs ss =
return $
[ StandaloneDerivD Nothing [] (AppT x y)
| x <- ConT . mkName <$> cs
, y <- ConT . mkName <$> ss
]

500
lib/Internal/Types.hs
View File

@ -1,10 +1,12 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Internal.Types where
import Control.Monad.Except
import Data.Fix (Fix (..), foldFix)
import Data.Functor.Foldable (embed)
import qualified Data.Functor.Foldable.TH as TH
@ -12,6 +14,7 @@ import Database.Persist.Sql hiding (Desc, In, Statement)
import Database.Persist.TH
import Dhall hiding (embed, maybe)
import Dhall.TH
import Internal.TH (deriveProduct)
import Language.Haskell.TH.Syntax (Lift)
import RIO
import qualified RIO.Map as M
@ -25,109 +28,131 @@ import Text.Regex.TDFA
-------------------------------------------------------------------------------
makeHaskellTypesWith
(defaultGenerateOptions {generateToDhallInstance = False})
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
, MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
, MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
, MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat"
, MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat"
, MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
, MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
, SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global"
, SingleConstructor "TemporalScope" "TemporalScope" "(./dhall/Types.dhall).TemporalScope"
, SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
, SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
, SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
, SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
, -- , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
-- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
-- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-- , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
, SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
, -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
, SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket"
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
, SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
, SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period"
, SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
-- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
-- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_"
-- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
-- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
]
deriveProduct
["Eq", "Show", "Generic", "FromDhall"]
[ "Currency"
, "Tag"
, "TimeUnit"
, "Weekday"
, "WeekdayPat"
, "RepeatPat"
, "MDYPat"
, "Gregorian"
, "GregorianM"
, "Interval"
, "ModPat"
, "CronPat"
, "DatePat"
, "TaggedAcnt"
, "Budget"
, "Income"
, "ShadowTransfer"
, "TransferMatcher"
, "AcntSet"
, "DateMatcher"
, "ValMatcher"
, "YMDMatcher"
, "BudgetCurrency"
, "Exchange"
, "EntryNumGetter"
, "TemporalScope"
, "SqlConfig"
, "PretaxValue"
, "TaxValue"
, "TaxBracket"
, "TaxProgression"
, "TaxMethod"
, "PosttaxValue"
, "BudgetTransferValue"
, "BudgetTransferType"
, "Period"
, "PeriodType"
, "HourlyPeriod"
]
-------------------------------------------------------------------------------
-- lots of instances for dhall types
deriving instance Eq Currency
deriving instance Lift Currency
deriving instance Hashable Currency
deriving instance Eq Tag
deriving instance Lift Tag
deriving instance Hashable Tag
deriving instance Eq TimeUnit
deriving instance Ord TimeUnit
deriving instance Show TimeUnit
deriving instance Hashable TimeUnit
deriving instance Eq Weekday
deriving instance Ord Weekday
deriving instance Show Weekday
deriving instance Hashable Weekday
deriving instance Enum Weekday
deriving instance Eq WeekdayPat
deriving instance Ord WeekdayPat
deriving instance Show WeekdayPat
deriving instance Hashable WeekdayPat
deriving instance Show RepeatPat
deriving instance Eq RepeatPat
deriving instance Ord RepeatPat
deriving instance Hashable RepeatPat
deriving instance Show MDYPat
deriving instance Eq MDYPat
deriving instance Ord MDYPat
deriving instance Hashable MDYPat
deriving instance Eq Gregorian
deriving instance Show Gregorian
deriving instance Hashable Gregorian
deriving instance Eq GregorianM
deriving instance Show GregorianM
deriving instance Hashable GregorianM
-- Dhall.TH rearranges my fields :(
@ -144,57 +169,56 @@ instance Ord GregorianM where
GregorianM {gmYear = y, gmMonth = m}
GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
deriving instance Eq Interval
deriving instance Ord Interval
deriving instance Hashable Interval
deriving instance Eq ModPat
deriving instance Ord ModPat
deriving instance Show ModPat
deriving instance Hashable ModPat
deriving instance Eq CronPat
deriving instance Ord CronPat
deriving instance Show CronPat
deriving instance Hashable CronPat
deriving instance Eq DatePat
deriving instance Ord DatePat
deriving instance Show DatePat
deriving instance Hashable DatePat
type BudgetTransfer =
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
deriving instance Hashable BudgetTransfer
deriving instance Generic BudgetTransfer
deriving instance FromDhall BudgetTransfer
data Budget = Budget
{ budgetLabel :: Text
, incomes :: [Income]
, pretax :: [IntervalAllocation]
, tax :: [IntervalAllocation]
, posttax :: [IntervalAllocation]
, transfers :: [Transfer]
, shadowTransfers :: [ShadowTransfer]
{ bgtLabel :: Text
, bgtIncomes :: [Income]
, bgtPretax :: [MultiAllocation PretaxValue]
, bgtTax :: [MultiAllocation TaxValue]
, bgtPosttax :: [MultiAllocation PosttaxValue]
, bgtTransfers :: [BudgetTransfer]
, bgtShadowTransfers :: [ShadowTransfer]
}
deriving instance Eq Budget
deriving instance Hashable PretaxValue
deriving instance Generic Budget
deriving instance Hashable TaxBracket
deriving instance Hashable TaxProgression
deriving instance Hashable TaxMethod
deriving instance Hashable TaxValue
deriving instance Hashable PosttaxValue
deriving instance Hashable Budget
deriving instance FromDhall Budget
deriving instance Hashable BudgetTransferValue
deriving instance Show TaggedAcnt
deriving instance Eq TaggedAcnt
deriving instance Hashable BudgetTransferType
deriving instance Hashable TaggedAcnt
@ -203,70 +227,61 @@ deriving instance Ord TaggedAcnt
type CurID = T.Text
data Income = Income
{ incGross :: Decimal
{ incGross :: Double
, incCurrency :: CurID
, incWhen :: DatePat
, incPretax :: [Allocation]
, incTaxes :: [Allocation]
, incPosttax :: [Allocation]
, incPretax :: [SingleAllocation PretaxValue]
, incTaxes :: [SingleAllocation TaxValue]
, incPosttax :: [SingleAllocation PosttaxValue]
, incFrom :: TaggedAcnt
, incToBal :: TaggedAcnt
, incPayPeriod :: !Period
}
deriving instance Eq Income
deriving instance Hashable HourlyPeriod
deriving instance Generic Income
deriving instance Hashable PeriodType
deriving instance Hashable Period
deriving instance Hashable Income
deriving instance FromDhall Income
deriving instance (Ord w, Ord v) => Ord (Amount w v)
deriving instance Show Amount
deriving instance Generic (Amount w v)
deriving instance Eq Amount
deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v)
deriving instance Ord Amount
deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)
deriving instance Hashable Amount
-- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
deriving instance Show Exchange
deriving instance (Show w, Show v) => Show (Amount w v)
deriving instance Eq Exchange
deriving instance (Eq w, Eq v) => Eq (Amount w v)
deriving instance Hashable Exchange
deriving instance Show BudgetCurrency
deriving instance Eq BudgetCurrency
deriving instance Hashable BudgetCurrency
data Allocation_ a = Allocation_
data Allocation w v = Allocation
{ alloTo :: TaggedAcnt
, alloAmts :: [a]
, alloCur :: BudgetCurrency
, alloAmts :: [Amount w v]
, alloCur :: CurID
}
deriving (Show)
deriving (Eq, Show, Generic, Hashable)
type Allocation = Allocation_ Amount
instance Bifunctor Amount where
bimap f g a@Amount {amtWhen, amtValue} = a {amtWhen = f amtWhen, amtValue = g amtValue}
deriving instance Eq Allocation
instance Bifunctor Allocation where
bimap f g a@Allocation {alloAmts} = a {alloAmts = fmap (bimap f g) alloAmts}
deriving instance Generic Allocation
deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Allocation w v)
deriving instance Hashable Allocation
type MultiAllocation = Allocation Interval
deriving instance FromDhall Allocation
type IntervalAllocation = Allocation_ IntervalAmount
deriving instance Eq IntervalAllocation
deriving instance Generic IntervalAllocation
deriving instance Hashable IntervalAllocation
deriving instance FromDhall IntervalAllocation
type SingleAllocation = Allocation ()
toPersistText :: Show a => a -> PersistValue
toPersistText = PersistText . T.pack . show
@ -278,98 +293,35 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
fromPersistText what x =
Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
deriving instance Show AmountType
-- this is necessary since dhall will reverse the order when importing
instance Ord Interval where
compare
Interval {intStart = s0, intEnd = e0}
Interval {intStart = s1, intEnd = e1} =
compare (s0, e0) (s1, e1)
deriving instance Eq AmountType
deriving instance Ord AmountType
deriving instance Hashable AmountType
data TimeAmount a = TimeAmount
{ taWhen :: a
, taAmt :: Amount
, taAmtType :: AmountType
data Transfer a c w v = Transfer
{ transFrom :: a
, transTo :: a
, transAmounts :: [Amount w v]
, transCurrency :: c
}
deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
type DateAmount = TimeAmount DatePat
-- deriving instance Eq DateAmount
-- deriving instance Generic DateAmount
-- deriving instance Hashable DateAmount
-- deriving instance FromDhall DateAmount
type IntervalAmount = TimeAmount Interval
-- deriving instance Eq IntervalAmount
-- deriving instance Ord IntervalAmount
-- deriving instance Generic IntervalAmount
-- deriving instance Hashable IntervalAmount
-- deriving instance FromDhall IntervalAmount
data Transfer = Transfer
{ transFrom :: TaggedAcnt
, transTo :: TaggedAcnt
, transAmounts :: [DateAmount]
, transCurrency :: BudgetCurrency
}
deriving instance Eq Transfer
deriving instance Generic Transfer
deriving instance Hashable Transfer
deriving instance FromDhall Transfer
deriving instance Eq ShadowTransfer
deriving (Eq, Show)
deriving instance Hashable ShadowTransfer
deriving instance Eq AcntSet
deriving instance Hashable AcntSet
deriving instance Eq ShadowMatch
deriving instance Hashable TransferMatcher
deriving instance Hashable ShadowMatch
deriving instance Hashable ValMatcher
deriving instance Eq MatchVal
deriving instance Hashable YMDMatcher
deriving instance Hashable MatchVal
deriving instance Show MatchVal
deriving instance Eq MatchYMD
deriving instance Hashable MatchYMD
deriving instance Show MatchYMD
deriving instance Eq MatchDate
deriving instance Hashable MatchDate
deriving instance Show MatchDate
deriving instance Eq Decimal
deriving instance Ord Decimal
deriving instance Hashable Decimal
deriving instance Show Decimal
deriving instance Hashable DateMatcher
-- TODO this just looks silly...but not sure how to simplify it
instance Ord MatchYMD where
instance Ord YMDMatcher where
compare (Y y) (Y y') = compare y y'
compare (YM g) (YM g') = compare g g'
compare (YMD g) (YMD g') = compare g g'
@ -384,21 +336,13 @@ gregM :: Gregorian -> GregorianM
gregM Gregorian {gYear = y, gMonth = m} =
GregorianM {gmYear = y, gmMonth = m}
instance Ord MatchDate where
instance Ord DateMatcher where
compare (On d) (On d') = compare d d'
compare (In d r) (In d' r') = compare d d' <> compare r r'
compare (On d) (In d' _) = compare d d' <> LT
compare (In d _) (On d') = compare d d' <> GT
deriving instance Eq SplitNum
deriving instance Hashable SplitNum
deriving instance Show SplitNum
deriving instance Eq Manual
deriving instance Hashable Manual
deriving instance Hashable EntryNumGetter
-------------------------------------------------------------------------------
-- top level type with fixed account tree to unroll the recursion in the dhall
@ -431,10 +375,10 @@ deriving instance FromDhall AccountRootF
type AccountRoot = AccountRoot_ AccountTree
data Config_ a = Config_
{ global :: !Global
{ global :: !TemporalScope
, budget :: ![Budget]
, currencies :: ![Currency]
, statements :: ![Statement]
, statements :: ![History]
, accounts :: !a
, tags :: ![Tag]
, sqlConfig :: !SqlConfig
@ -468,23 +412,30 @@ type AcntID = T.Text
type TagID = T.Text
data Statement
= StmtManual !Manual
| StmtImport !Import
deriving (Eq, Hashable, Generic, FromDhall)
type HistTransfer = Transfer AcntID CurID DatePat Double
data Split a v c t = Split
{ sAcnt :: !a
, sValue :: !v
, sCurrency :: !c
, sComment :: !T.Text
, sTags :: ![t]
}
deriving (Eq, Generic, Hashable, Show)
deriving instance Generic HistTransfer
type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
deriving instance Hashable HistTransfer
instance FromDhall ExpSplit
deriving instance FromDhall HistTransfer
data History
= HistTransfer !HistTransfer
| HistStatement !Statement
deriving (Eq, Generic, Hashable, FromDhall)
type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
instance FromDhall EntryGetter
deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
deriving instance Generic (Entry a v c t)
deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
data Tx s = Tx
{ txDescr :: !T.Text
@ -493,7 +444,7 @@ data Tx s = Tx
}
deriving (Generic)
type ExpTx = Tx ExpSplit
type ExpTx = Tx EntryGetter
instance FromDhall ExpTx
@ -507,66 +458,74 @@ data TxOpts re = TxOpts
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
data Import = Import
{ impPaths :: ![FilePath]
, impMatches :: ![Match T.Text]
, impDelim :: !Word
, impTxOpts :: !(TxOpts T.Text)
, impSkipLines :: !Natural
data Statement = Statement
{ stmtPaths :: ![FilePath]
, stmtParsers :: ![StatementParser T.Text]
, stmtDelim :: !Word
, stmtTxOpts :: !(TxOpts T.Text)
, stmtSkipLines :: !Natural
}
deriving (Eq, Hashable, Generic, FromDhall)
-- | the value of a field in split (text version)
-- can either be a raw (constant) value, a lookup from the record, or a map
-- between the lookup and some other value
data SplitText t
data EntryTextGetter t
= ConstT !t
| LookupT !T.Text
| MapT !(FieldMap T.Text t)
| Map2T !(FieldMap (T.Text, T.Text) t)
deriving (Eq, Generic, Hashable, Show, FromDhall)
type SplitCur = SplitText CurID
type SplitCur = EntryTextGetter CurID
type SplitAcnt = SplitText AcntID
type SplitAcnt = EntryTextGetter AcntID
data Field k v = Field
{ fKey :: !k
, fVal :: !v
}
deriving (Show, Eq, Hashable, Generic, FromDhall, Foldable, Traversable)
deriving instance (Show k, Show v) => Show (Field k v)
deriving instance (Eq k, Eq v) => Eq (Field k v)
deriving instance Generic (Field k v)
deriving instance (Hashable k, Hashable v) => Hashable (Field k v)
deriving instance Foldable (Field k)
deriving instance Traversable (Field k)
deriving instance (FromDhall k, FromDhall v) => FromDhall (Field k v)
instance Functor (Field f) where
fmap f (Field k v) = Field k $ f v
type FieldMap k v = Field k (M.Map k v)
data MatchOther re
data FieldMatcher re
= Desc !(Field T.Text re)
| Val !(Field T.Text MatchVal)
| Val !(Field T.Text ValMatcher)
deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
deriving instance Show (MatchOther T.Text)
deriving instance Show (FieldMatcher T.Text)
data ToTx = ToTx
{ ttCurrency :: !SplitCur
, ttPath :: !SplitAcnt
, ttSplit :: ![ExpSplit]
data TxGetter = TxGetter
{ tgCurrency :: !SplitCur
, tgAcnt :: !SplitAcnt
, tgEntries :: ![EntryGetter]
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
data Match re = Match
{ mDate :: !(Maybe MatchDate)
, mVal :: !MatchVal
, mDesc :: !(Maybe re)
, mOther :: ![MatchOther re]
, mTx :: !(Maybe ToTx)
, mTimes :: !(Maybe Natural)
, mPriority :: !Integer
data StatementParser re = StatementParser
{ spDate :: !(Maybe DateMatcher)
, spVal :: !ValMatcher
, spDesc :: !(Maybe re)
, spOther :: ![FieldMatcher re]
, spTx :: !(Maybe TxGetter)
, spTimes :: !(Maybe Natural)
, spPriority :: !Integer
}
deriving (Eq, Generic, Hashable, FromDhall, Functor)
deriving instance Show (Match T.Text)
deriving instance Show (StatementParser T.Text)
--------------------------------------------------------------------------------
-- DATABASE MODEL
@ -582,6 +541,7 @@ CommitR sql=commits
CurrencyR sql=currencies
symbol T.Text
fullname T.Text
precision Int
deriving Show Eq
TagR sql=tags
symbol T.Text
@ -644,7 +604,7 @@ instance PersistField ConfigType where
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
type CurrencyMap = M.Map CurID CurrencyRId
type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
type TagMap = M.Map TagID TagRId
@ -655,12 +615,17 @@ data DBState = DBState
, kmBudgetInterval :: !Bounds
, kmStatementInterval :: !Bounds
, kmNewCommits :: ![Int]
, kmOldCommits :: ![Int]
, kmConfigDir :: !FilePath
, kmTagAll :: ![Entity TagR]
, kmAcntPaths :: ![AccountPathR]
, kmAcntsOld :: ![Entity AccountR]
, kmCurrenciesOld :: ![Entity CurrencyR]
}
type MappingT m = ReaderT DBState (SqlPersistT m)
type CurrencyM = Reader CurrencyMap
type KeySplit = Split AccountRId Rational CurrencyRId TagRId
type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
type KeyTx = Tx KeySplit
@ -668,12 +633,11 @@ type TreeR = Tree ([T.Text], AccountRId)
type Balances = M.Map AccountRId Rational
type BalanceM m = ReaderT (MVar Balances) m
type BalanceM = ReaderT (MVar Balances)
class MonadUnliftIO m => MonadFinance m where
askDBState :: (DBState -> a) -> m a
type MonadFinance = MonadReader DBState
instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where
askDBState :: MonadFinance m => (DBState -> a) -> m a
askDBState = asks
class MonadUnliftIO m => MonadBalance m where
@ -753,9 +717,9 @@ accountSign IncomeT = Credit
accountSign LiabilityT = Credit
accountSign EquityT = Credit
type RawSplit = Split AcntID (Maybe Rational) CurID TagID
type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
type BalSplit = Split AcntID Rational CurID TagID
type BalSplit = Entry AcntID Rational CurID TagID
type RawTx = Tx RawSplit
@ -797,19 +761,23 @@ data InsertError
| ConversionError !T.Text
| LookupError !LookupSuberr !T.Text
| BalanceError !BalanceType !CurID ![RawSplit]
| IncomeError !DatePat
| IncomeError !Day !T.Text !Rational
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| BoundsError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![MatchRe]
| PeriodError !Day !Day
deriving (Show)
newtype InsertException = InsertException [InsertError] deriving (Show)
newtype InsertException = InsertException [InsertError]
deriving (Show, Semigroup) via [InsertError]
instance Exception InsertException
type EitherErr = Either InsertError
type MonadInsertError = MonadError InsertException
type EitherErrs = Either [InsertError]
type InsertExceptT = ExceptT InsertException
type InsertExcept = InsertExceptT Identity
data XGregorian = XGregorian
{ xgYear :: !Int
@ -818,11 +786,11 @@ data XGregorian = XGregorian
, xgDayOfWeek :: !Int
}
type MatchRe = Match (T.Text, Regex)
type MatchRe = StatementParser (T.Text, Regex)
type TxOptsRe = TxOpts (T.Text, Regex)
type MatchOtherRe = MatchOther (T.Text, Regex)
type FieldMatcherRe = FieldMatcher (T.Text, Regex)
instance Show (Match (T.Text, Regex)) where
instance Show (StatementParser (T.Text, Regex)) where
show = show . fmap fst

477
lib/Internal/Utils.hs
View File

@ -1,5 +1,6 @@
module Internal.Utils
( compareDate
, fromWeekday
, inBounds
, expandBounds
, fmtRational
@ -7,16 +8,33 @@ module Internal.Utils
, fromGregorian'
, resolveBounds
, resolveBounds_
, leftToMaybe
, dec2Rat
, concatEithers2
, concatEithers3
, concatEither3
, concatEither2
, concatEitherL
, concatEithersL
, concatEither2M
, concatEithers2M
, liftInner
, liftExceptT
, liftExcept
, liftIOExcept
, liftIOExceptT
, combineError
, combineError_
, combineError3
, combineErrors
, mapErrors
, combineErrorM
, combineErrorM3
, combineErrorIO2
, combineErrorIO3
, combineErrorIOM2
, combineErrorIOM3
, collectErrorsIO
, mapErrorsIO
-- , leftToMaybe
-- , concatEithers2
-- , concatEithers3
-- , concatEither3
-- , concatEither2
-- , concatEitherL
-- , concatEithersL
-- , concatEither2M
-- , concatEithers2M
, parseRational
, showError
, unlessLeft_
@ -32,14 +50,19 @@ module Internal.Utils
, sndOf3
, thdOf3
, xGregToDay
, plural
-- , plural
, compileMatch
, compileOptions
, dateMatches
, valMatches
, roundPrecision
, roundPrecisionCur
)
where
import Control.Monad.Error.Class
import Control.Monad.Except
import Control.Monad.Reader
import Data.Time.Format.ISO8601
import GHC.Real
import Internal.Types
@ -55,6 +78,16 @@ import Text.Regex.TDFA.Text
--------------------------------------------------------------------------------
-- dates
-- | Lame weekday converter since day of weeks aren't in dhall (yet)
fromWeekday :: Weekday -> DayOfWeek
fromWeekday Mon = Monday
fromWeekday Tue = Tuesday
fromWeekday Wed = Wednesday
fromWeekday Thu = Thursday
fromWeekday Fri = Friday
fromWeekday Sat = Saturday
fromWeekday Sun = Sunday
-- | find the next date
-- this is meant to go in a very tight loop and be very fast (hence no
-- complex date functions, most of which heavily use 'mod' and friends)
@ -97,22 +130,22 @@ gregMTup GregorianM {gmYear, gmMonth} =
data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int
fromMatchYMD :: MatchYMD -> YMD_
fromMatchYMD m = case m of
fromYMDMatcher :: YMDMatcher -> YMD_
fromYMDMatcher m = case m of
Y y -> Y_ $ fromIntegral y
YM g -> uncurry YM_ $ gregMTup g
YMD g -> uncurry3 YMD_ $ gregTup g
compareDate :: MatchDate -> Day -> Ordering
compareDate :: DateMatcher -> Day -> Ordering
compareDate (On md) x =
case fromMatchYMD md of
case fromYMDMatcher md of
Y_ y' -> compare y y'
YM_ y' m' -> compare (y, m) (y', m')
YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
where
(y, m, d) = toGregorian x
compareDate (In md offset) x = do
case fromMatchYMD md of
case fromYMDMatcher md of
Y_ y' -> compareRange y' y
YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
YMD_ y' m' d' ->
@ -132,17 +165,17 @@ fromGregorian' = uncurry3 fromGregorian . gregTup
inBounds :: (Day, Day) -> Day -> Bool
inBounds (d0, d1) x = d0 <= x && x < d1
resolveBounds :: Interval -> EitherErr Bounds
resolveBounds :: Interval -> InsertExcept Bounds
resolveBounds i@Interval {intStart = s} =
resolveBounds_ (s {gYear = gYear s + 50}) i
resolveBounds_ :: Gregorian -> Interval -> EitherErr Bounds
resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
resolveBounds_ def Interval {intStart = s, intEnd = e} =
case fromGregorian' <$> e of
Nothing -> Right $ toBounds $ fromGregorian' def
Nothing -> return $ toBounds $ fromGregorian' def
Just e_
| s_ < e_ -> Right $ toBounds e_
| otherwise -> Left $ BoundsError s e
| s_ < e_ -> return $ toBounds e_
| otherwise -> throwError $ InsertException [BoundsError s e]
where
s_ = fromGregorian' s
toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
@ -153,103 +186,193 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
--------------------------------------------------------------------------------
-- matching
matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes RawTx)
matches
Match {mTx, mOther, mVal, mDate, mDesc}
StatementParser {spTx, spOther, spVal, spDate, spDesc}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
res <- concatEither3 val other desc $ \x y z -> x && y && z
if date && res
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
else Right MatchFail
res <- liftInner $
combineError3 val other desc $
\x y z -> x && y && z && date
if res
then maybe (return MatchSkip) convert spTx
else return MatchFail
where
val = valMatches mVal trAmount
date = maybe True (`dateMatches` trDate) mDate
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
convert (ToTx cur a ss) = toTx cur a ss r
val = valMatches spVal trAmount
date = maybe True (`dateMatches` trDate) spDate
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
combineError3 acntRes curRes ssRes $ \a c ss ->
let fromSplit =
Split
{ sAcnt = a_
, sCurrency = c_
, sValue = Just trAmount
, sComment = ""
, sTags = [] -- TODO what goes here?
Entry
{ eAcnt = a
, eCurrency = c
, eValue = Just trAmount
, eComment = ""
, eTags = [] -- TODO what goes here?
}
in Tx
{ txDate = trDate
, txDescr = trDesc
, txSplits = fromSplit : ss_
, txSplits = fromSplit : ss
}
where
acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
acntRes = liftInner $ resolveAcnt r sa
curRes = liftInner $ resolveCurrency r sc
ssRes = combineErrors $ fmap (resolveEntry r) toSplits
valMatches :: MatchVal -> Rational -> EitherErr Bool
valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
| Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
| Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
| otherwise =
Right $
checkMaybe (s ==) mvSign
&& checkMaybe (n ==) mvNum
&& checkMaybe ((d * fromIntegral p ==) . fromIntegral) mvDen
return $
checkMaybe (s ==) vmSign
&& checkMaybe (n ==) vmNum
&& checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen
where
(n, d) = properFraction $ abs x
p = 10 ^ mvPrec
p = 10 ^ vmPrec
s = signum x >= 0
checkMaybe = maybe True
dateMatches :: MatchDate -> Day -> Bool
dateMatches :: DateMatcher -> Day -> Bool
dateMatches md = (EQ ==) . compareDate md
otherMatches :: M.Map T.Text T.Text -> MatchOtherRe -> EitherErr Bool
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
otherMatches dict m = case m of
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
where
lookup_ t n = lookupErr (MatchField t) n dict
resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
concatEithers2 acRes valRes $
\(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawSplit
resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do
m <- ask
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
v' <- mapM (roundPrecisionCur c m) v
return $ s {eAcnt = a, eValue = v', eCurrency = c}
where
acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
valRes = plural $ mapM (resolveValue r) v
acntRes = resolveAcnt r eAcnt
curRes = resolveCurrency r eCurrency
valRes = mapM (resolveValue r) eValue
resolveValue :: TxRecord -> SplitNum -> EitherErr Rational
liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
liftInner = mapExceptT (return . runIdentity)
liftExceptT :: MonadError e m => ExceptT e m a -> m a
liftExceptT x = runExceptT x >>= either throwError return
liftExcept :: MonadError e m => Except e a -> m a
liftExcept = either throwError return . runExcept
-- tryError :: MonadError e m => m a -> m (Either e a)
-- tryError action = (Right <$> action) `catchError` (pure . Left)
liftIOExceptT :: MonadIO m => InsertExceptT m a -> m a
liftIOExceptT = fromEither <=< runExceptT
liftIOExcept :: MonadIO m => InsertExcept a -> m a
liftIOExcept = fromEither . runExcept
combineError :: MonadError InsertException m => m a -> m b -> (a -> b -> c) -> m c
combineError a b f = combineErrorM a b (\x y -> pure $ f x y)
combineError_ :: MonadError InsertException m => m a -> m b -> m ()
combineError_ a b = do
_ <- catchError a $ \e ->
throwError =<< catchError (e <$ b) (return . (e <>))
_ <- b
return ()
combineErrorM :: MonadError InsertException m => m a -> m b -> (a -> b -> m c) -> m c
combineErrorM a b f = do
a' <- catchError a $ \e ->
throwError =<< catchError (e <$ b) (return . (e <>))
f a' =<< b
combineError3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
combineError3 a b c f =
combineError (combineError a b (,)) c $ \(x, y) z -> f x y z
combineErrorM3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
combineErrorM3 a b c f = do
combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z
combineErrors :: MonadError InsertException m => [m a] -> m [a]
combineErrors = mapErrors id
mapErrors :: MonadError InsertException m => (a -> m b) -> [a] -> m [b]
mapErrors f xs = do
ys <- mapM (go . f) xs
case partitionEithers ys of
([], zs) -> return zs
(e : es, _) -> throwError $ foldr (<>) e es
where
go x = catchError (Right <$> x) (pure . Left)
combineErrorIO2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> c) -> m c
combineErrorIO2 a b f = combineErrorIOM2 a b (\x y -> pure $ f x y)
combineErrorIO3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
combineErrorIO3 a b c f = combineErrorIOM3 a b c (\x y z -> pure $ f x y z)
combineErrorIOM2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> m c) -> m c
combineErrorIOM2 a b f = do
a' <- catch a $ \(InsertException es) ->
(throwIO . InsertException)
=<< catch (es <$ b) (\(InsertException es') -> return (es' ++ es))
f a' =<< b
combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
combineErrorIOM3 a b c f =
combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z
mapErrorsIO :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b]
mapErrorsIO f xs = do
ys <- mapM (go . f) xs
case partitionEithers ys of
([], zs) -> return zs
(es, _) -> throwIO $ InsertException $ concat es
where
go x = catch (Right <$> x) $ \(InsertException es) -> pure $ Left es
collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a]
collectErrorsIO = mapErrorsIO id
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
resolveValue r s = case s of
(LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r)
(ConstN c) -> Right $ dec2Rat c
AmountN -> Right $ trAmount r
(LookupN t) -> readDouble =<< lookupErr SplitValField t (trOther r)
(ConstN c) -> return c
-- TODO don't coerce to rational in trAmount
AmountN -> return $ fromRational $ trAmount r
resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text
resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text
resolveAcnt = resolveSplitField AcntField
resolveCurrency :: TxRecord -> SplitCur -> EitherErrs T.Text
resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text
resolveCurrency = resolveSplitField CurField
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text
resolveSplitField t TxRecord {trOther = o} s = case s of
ConstT p -> Right p
LookupT f -> plural $ lookup_ f o
MapT (Field f m) -> plural $ do
ConstT p -> return p
LookupT f -> lookup_ f o
MapT (Field f m) -> do
k <- lookup_ f o
lookup_ k m
Map2T (Field (f1, f2) m) -> do
(k1, k2) <- concatEither2 (lookup_ f1 o) (lookup_ f2 o) (,)
plural $ lookup_ (k1, k2) m
(k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
lookup_ (k1, k2) m
where
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErr v
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
lookup_ = lookupErr (SplitIDField t)
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErr v
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
lookupErr what k m = case M.lookup k m of
Just x -> Right x
_ -> Left $ LookupError what $ showT k
Just x -> return x
_ -> throwError $ InsertException [LookupError what $ showT k]
parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
parseRational (pat, re) s = case matchGroupsMaybe s re of
@ -278,7 +401,12 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
k <- readSign sign
return (k, w)
readRational :: T.Text -> EitherErr Rational
readDouble :: T.Text -> InsertExcept Double
readDouble s = case readMaybe $ T.unpack s of
Just x -> return x
Nothing -> throwError $ InsertException [ConversionError s]
readRational :: T.Text -> InsertExcept Rational
readRational s = case T.split (== '.') s of
[x] -> maybe err (return . fromInteger) $ readT x
[x, y] -> case (readT x, readT y) of
@ -290,7 +418,7 @@ readRational s = case T.split (== '.') s of
_ -> err
where
readT = readMaybe . T.unpack
err = Left $ ConversionError s
err = throwError $ InsertException [ConversionError s]
-- TODO smells like a lens
-- mapTxSplits :: (a -> b) -> Tx a -> Tx b
@ -307,11 +435,16 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
txt = T.pack . show
pad i c z = T.append (T.replicate (i - T.length z) c) z
dec2Rat :: Decimal -> Rational
dec2Rat D {sign, whole, decimal, precision} =
k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
roundPrecision :: Natural -> Double -> Rational
roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
where
k = if sign then 1 else -1
p = 10 ^ n
roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational
roundPrecisionCur c m x =
case M.lookup c m of
Just (_, n) -> return $ roundPrecision n x
Nothing -> throwError $ InsertException [undefined]
acntPath2Text :: AcntPath -> T.Text
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
@ -371,8 +504,24 @@ showError other = case other of
idName TagField = "tag"
matchName MatchNumeric = "numeric"
matchName MatchText = "text"
(IncomeError dp) ->
[T.append "Income allocations exceed total: datepattern=" $ showT dp]
(IncomeError day name balance) ->
[ T.unwords
[ "Income allocations for budget"
, singleQuote name
, "exceed total on day"
, showT day
, "where balance is"
, showT (fromRational balance :: Double)
]
]
(PeriodError start next) ->
[ T.unwords
[ "First pay period on "
, singleQuote $ showT start
, "must start before first income payment on "
, singleQuote $ showT next
]
]
(BalanceError t cur rss) ->
[ T.unwords
[ msg
@ -402,32 +551,32 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
]
showMatch :: MatchRe -> T.Text
showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriority = p} =
showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
where
kvs =
[ ("date", showMatchDate <$> d)
, ("val", showMatchVal v)
, ("desc", fst <$> e)
[ ("date", showDateMatcher <$> spDate)
, ("val", showValMatcher spVal)
, ("desc", fst <$> spDesc)
, ("other", others)
, ("counter", Just $ maybe "Inf" showT n)
, ("priority", Just $ showT p)
, ("counter", Just $ maybe "Inf" showT spTimes)
, ("priority", Just $ showT spPriority)
]
others = case o of
others = case spOther of
[] -> Nothing
xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs
-- | Convert match date to text
-- Single date matches will just show the single date, and ranged matches will
-- show an interval like [YY-MM-DD, YY-MM-DD)
showMatchDate :: MatchDate -> T.Text
showMatchDate md = case md of
(On x) -> showMatchYMD x
(In start n) -> T.concat ["[", showMatchYMD start, " ", showYMD_ end, ")"]
showDateMatcher :: DateMatcher -> T.Text
showDateMatcher md = case md of
(On x) -> showYMDMatcher x
(In start n) -> T.concat ["[", showYMDMatcher start, " ", showYMD_ end, ")"]
where
-- TODO not DRY (this shifting thing happens during the comparison
-- function (kinda)
end = case fromMatchYMD start of
end = case fromYMDMatcher start of
Y_ y -> Y_ $ y + fromIntegral n
YM_ y m ->
let (y_, m_) = divMod (m + fromIntegral n - 1) 12
@ -439,8 +588,8 @@ showMatchDate md = case md of
fromGregorian y m d
-- | convert YMD match to text
showMatchYMD :: MatchYMD -> T.Text
showMatchYMD = showYMD_ . fromMatchYMD
showYMDMatcher :: YMDMatcher -> T.Text
showYMDMatcher = showYMD_ . fromYMDMatcher
showYMD_ :: YMD_ -> T.Text
showYMD_ md =
@ -451,19 +600,19 @@ showYMD_ md =
YM_ y m -> [fromIntegral y, m]
YMD_ y m d -> [fromIntegral y, m, d]
showMatchVal :: MatchVal -> Maybe T.Text
showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
showValMatcher :: ValMatcher -> Maybe T.Text
showValMatcher ValMatcher {vmSign = Nothing, vmNum = Nothing, vmDen = Nothing} = Nothing
showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} =
Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
where
kvs =
[ ("sign", (\s -> if s then "+" else "-") <$> mvSign)
, ("numerator", showT <$> mvNum)
, ("denominator", showT <$> mvDen)
, ("precision", Just $ showT mvPrec)
[ ("sign", (\s -> if s then "+" else "-") <$> vmSign)
, ("numerator", showT <$> vmNum)
, ("denominator", showT <$> vmDen)
, ("precision", Just $ showT vmPrec)
]
showMatchOther :: MatchOtherRe -> T.Text
showMatchOther :: FieldMatcherRe -> T.Text
showMatchOther (Desc (Field f (re, _))) =
T.unwords ["desc field", singleQuote f, "with re", singleQuote re]
showMatchOther (Val (Field f mv)) =
@ -471,15 +620,15 @@ showMatchOther (Val (Field f mv)) =
[ "val field"
, singleQuote f
, "with match value"
, singleQuote $ fromMaybe "*" $ showMatchVal mv
, singleQuote $ fromMaybe "*" $ showValMatcher mv
]
showSplit :: RawSplit -> T.Text
showSplit Split {sAcnt = a, sValue = v, sComment = c} =
showSplit Entry {eAcnt, eValue, eComment} =
keyVals
[ ("account", a)
, ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))
, ("comment", doubleQuote c)
[ ("account", eAcnt)
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
, ("comment", doubleQuote eComment)
]
singleQuote :: T.Text -> T.Text
@ -500,51 +649,51 @@ showT = T.pack . show
--------------------------------------------------------------------------------
-- pure error processing
concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
concatEither2 a b fun = case (a, b) of
(Right a_, Right b_) -> Right $ fun a_ b_
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
-- concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
-- concatEither2 a b fun = case (a, b) of
-- (Right a_, Right b_) -> Right $ fun a_ b_
-- _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
concatEither2M a b fun = case (a, b) of
(Right a_, Right b_) -> Right <$> fun a_ b_
_ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]
-- concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
-- concatEither2M a b fun = case (a, b) of
-- (Right a_, Right b_) -> Right <$> fun a_ b_
-- _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]
concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
concatEither3 a b c fun = case (a, b, c) of
(Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
-- concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
-- concatEither3 a b c fun = case (a, b, c) of
-- (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
-- _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
concatEithers2 a b = merge . concatEither2 a b
-- concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
-- concatEithers2 a b = merge . concatEither2 a b
concatEithers2M
:: Monad m
=> Either [x] a
-> Either [x] b
-> (a -> b -> m c)
-> m (Either [x] c)
concatEithers2M a b = fmap merge . concatEither2M a b
-- concatEithers2M
-- :: Monad m
-- => Either [x] a
-- -> Either [x] b
-- -> (a -> b -> m c)
-- -> m (Either [x] c)
-- concatEithers2M a b = fmap merge . concatEither2M a b
concatEithers3
:: Either [x] a
-> Either [x] b
-> Either [x] c
-> (a -> b -> c -> d)
-> Either [x] d
concatEithers3 a b c = merge . concatEither3 a b c
-- concatEithers3
-- :: Either [x] a
-- -> Either [x] b
-- -> Either [x] c
-- -> (a -> b -> c -> d)
-- -> Either [x] d
-- concatEithers3 a b c = merge . concatEither3 a b c
concatEitherL :: [Either x a] -> Either [x] [a]
concatEitherL as = case partitionEithers as of
([], bs) -> Right bs
(es, _) -> Left es
-- concatEitherL :: [Either x a] -> Either [x] [a]
-- concatEitherL as = case partitionEithers as of
-- ([], bs) -> Right bs
-- (es, _) -> Left es
concatEithersL :: [Either [x] a] -> Either [x] [a]
concatEithersL = merge . concatEitherL
-- concatEithersL :: [Either [x] a] -> Either [x] [a]
-- concatEithersL = merge . concatEitherL
leftToMaybe :: Either a b -> Maybe a
leftToMaybe (Left a) = Just a
leftToMaybe _ = Nothing
-- leftToMaybe :: Either a b -> Maybe a
-- leftToMaybe (Left a) = Just a
-- leftToMaybe _ = Nothing
unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
unlessLeft (Left es) _ = return (return es)
@ -560,11 +709,11 @@ unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero)
unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
plural :: Either a b -> Either [a] b
plural = first (: [])
-- plural :: Either a b -> Either [a] b
-- plural = first (: [])
merge :: Either [[a]] b -> Either [a] b
merge = first concat
-- merge :: Either [[a]] b -> Either [a] b
-- merge = first concat
--------------------------------------------------------------------------------
-- random functions
@ -608,23 +757,23 @@ thdOf3 (_, _, c) = c
-- -- these options barely do anything in terms of performance
-- compres = compile (blankCompOpt {newSyntax = True}) (blankExecOpt {captureGroups = False}) pat
compileOptions :: TxOpts T.Text -> EitherErr TxOptsRe
compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe
compileOptions o@TxOpts {toAmountFmt = pat} = do
re <- compileRegex True pat
return $ o {toAmountFmt = re}
compileMatch :: Match T.Text -> EitherErrs MatchRe
compileMatch m@Match {mDesc = d, mOther = os} = do
let dres = plural $ mapM go d
let ores = concatEitherL $ fmap (mapM go) os
concatEithers2 dres ores $ \d_ os_ -> m {mDesc = d_, mOther = os_}
compileMatch :: StatementParser T.Text -> InsertExcept MatchRe
compileMatch m@StatementParser {spDesc, spOther} = do
combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
where
go = compileRegex False
dres = mapM go spDesc
ores = combineErrors $ fmap (mapM go) spOther
compileRegex :: Bool -> T.Text -> EitherErr (Text, Regex)
compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex)
compileRegex groups pat = case res of
Right re -> Right (pat, re)
Left _ -> Left $ RegexError pat
Right re -> return (pat, re)
Left _ -> throwError $ InsertException [RegexError pat]
where
res =
compile
@ -632,10 +781,10 @@ compileRegex groups pat = case res of
(blankExecOpt {captureGroups = groups})
pat
matchMaybe :: T.Text -> Regex -> EitherErr Bool
matchMaybe :: T.Text -> Regex -> InsertExcept Bool
matchMaybe q re = case execute re q of
Right res -> Right $ isJust res
Left _ -> Left $ RegexError "this should not happen"
Right res -> return $ isJust res
Left _ -> throwError $ InsertException [RegexError "this should not happen"]
matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
matchGroupsMaybe q re = case regexec re q of

1
package.yaml
View File

@ -86,6 +86,7 @@ dependencies:
- data-fix
- filepath
- mtl
- persistent-mtl >= 0.3.0.0
library:
source-dirs: lib/

1
stack.yaml
View File

@ -46,6 +46,7 @@ extra-deps:
commit: ffd1ba94ef39b875aba8adc1c498f28aa02e36e4
subdirs: [dhall]
- hashable-1.3.5.0
- persistent-mtl-0.3.0.0
#
# extra-deps: []