Merge branch 'update_dhall_types'
This commit is contained in:
commit
48adbccdcc
40
app/Main.hs
40
app/Main.hs
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 }
|
1139
dhall/Types.dhall
1139
dhall/Types.dhall
File diff suppressed because it is too large
Load Diff
|
@ -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
|
||||
|
|
|
@ -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
|
||||
runMigration migrateAll
|
||||
more
|
||||
)
|
||||
-> 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)
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -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]
|
||||
-- TODO record number of times each match hits for debugging
|
||||
(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 (: []))
|
||||
|
|
|
@ -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
|
||||
]
|
|
@ -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,13 +633,12 @@ 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 = asks
|
||||
askDBState :: MonadFinance m => (DBState -> a) -> m a
|
||||
askDBState = asks
|
||||
|
||||
class MonadUnliftIO m => MonadBalance m where
|
||||
askBalances :: m (MVar Balances)
|
||||
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -86,6 +86,7 @@ dependencies:
|
|||
- data-fix
|
||||
- filepath
|
||||
- mtl
|
||||
- persistent-mtl >= 0.3.0.0
|
||||
|
||||
library:
|
||||
source-dirs: lib/
|
||||
|
|
|
@ -46,6 +46,7 @@ extra-deps:
|
|||
commit: ffd1ba94ef39b875aba8adc1c498f28aa02e36e4
|
||||
subdirs: [dhall]
|
||||
- hashable-1.3.5.0
|
||||
- persistent-mtl-0.3.0.0
|
||||
#
|
||||
# extra-deps: []
|
||||
|
||||
|
|
Loading…
Reference in New Issue