Merge branch 'update_dhall_types'

This commit is contained in:
Nathan Dwarshuis 2023-05-16 23:20:54 -04:00
commit 48adbccdcc
13 changed files with 2322 additions and 1287 deletions

View File

@ -2,8 +2,12 @@
module Main (main) where module Main (main) where
import Control.Monad.Except
import Control.Monad.IO.Rerunnable
import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import qualified Data.Text.IO as TI import qualified Data.Text.IO as TI
import Database.Persist.Monad
import Internal.Config import Internal.Config
import Internal.Database.Ops import Internal.Database.Ops
import Internal.Insert import Internal.Insert
@ -103,7 +107,7 @@ sync =
parse :: Options -> IO () parse :: Options -> IO ()
parse (Options c Reset) = do parse (Options c Reset) = do
config <- readConfig c config <- readConfig c
migrate_ (sqlConfig config) nukeTables runDB (sqlConfig config) nukeTables
parse (Options c DumpAccounts) = runDumpAccounts c parse (Options c DumpAccounts) = runDumpAccounts c
parse (Options c DumpAccountKeys) = runDumpAccountKeys c parse (Options c DumpAccountKeys) = runDumpAccountKeys c
parse (Options c DumpCurrencies) = runDumpCurrencies c parse (Options c DumpCurrencies) = runDumpCurrencies c
@ -155,19 +159,31 @@ runDumpAccountKeys c = do
t3 (_, _, x) = x t3 (_, _, x) = x
double x = (x, x) double x = (x, x)
runSync :: MonadUnliftIO m => FilePath -> m () runSync :: FilePath -> IO ()
runSync c = do runSync c = do
config <- readConfig c config <- readConfig c
handle err $ migrate_ (sqlConfig config) $ do let (hTs, hSs) = splitHistory $ statements config
res <- getDBState config pool <- runNoLoggingT $ mkPool $ sqlConfig config
case res of handle err $ do
Left es -> throwIO $ InsertException es -- _ <- askLoggerIO
Right s -> do
let run = mapReaderT $ flip runReaderT (s $ takeDirectory c) -- get the current DB state
es1 <- concat <$> mapM (run . insertBudget) (budget config) s <- runSqlQueryT pool $ do
es2 <- run $ insertStatements config runMigration migrateAll
let es = es1 ++ es2 fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
unless (null es) $ throwIO $ InsertException es
-- 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 where
err (InsertException es) = do err (InsertException es) = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es liftIO $ mapM_ TI.putStrLn $ concatMap showError es

View File

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

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 }

File diff suppressed because it is too large Load Diff

View File

@ -4,29 +4,16 @@ let List/map =
let T = ./Types.dhall 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 = let nullSplit =
\(a : T.SplitAcnt) -> \(a : T.EntryAcntGetter) ->
\(c : T.SplitCur) -> \(c : T.EntryCurGetter) ->
T.ExpSplit::{ sAcnt = a, sCurrency = c, sTags = [] : List T.TagID } T.EntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
let nullOpts = T.TxOpts::{=} let nullOpts = T.TxOpts::{=}
let nullVal = T.MatchVal::{=} let nullVal = T.ValMatcher::{=}
let nullMatch = T.Match::{=} let nullMatch = T.StatementParser::{=}
let nullCron = T.CronPat::{=} let nullCron = T.CronPat::{=}
@ -41,20 +28,20 @@ let cron1 =
\(d : Natural) -> \(d : Natural) ->
T.DatePat.Cron T.DatePat.Cron
( nullCron ( nullCron
// { cronYear = Some (T.MDYPat.Single y) // { cpYear = Some (T.MDYPat.Single y)
, cronMonth = Some (T.MDYPat.Single m) , cpMonth = Some (T.MDYPat.Single m)
, cronDay = Some (T.MDYPat.Single d) , cpDay = Some (T.MDYPat.Single d)
} }
) )
let matchInf_ = nullMatch 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 = 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 let match1_ = matchN_ 1
@ -68,61 +55,63 @@ let greg =
\(d : Natural) -> \(d : Natural) ->
{ gYear = y, gMonth = m, gDay = d } { 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 = let mYM =
\(y : Natural) -> \(y : Natural) ->
\(m : Natural) -> \(m : Natural) ->
T.MatchDate.On (T.MatchYMD.YM (gregM y m)) T.DateMatcher.On (T.YMDMatcher.YM (gregM y m))
let mYMD = let mYMD =
\(y : Natural) -> \(y : Natural) ->
\(m : Natural) -> \(m : Natural) ->
\(d : 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 = let mRngY =
\(y : Natural) -> \(y : Natural) ->
\(r : 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 = let mRngYM =
\(y : Natural) -> \(y : Natural) ->
\(m : Natural) -> \(m : Natural) ->
\(r : 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 = let mRngYMD =
\(y : Natural) -> \(y : Natural) ->
\(m : Natural) -> \(m : Natural) ->
\(d : Natural) -> \(d : Natural) ->
\(r : 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 = let partN =
\(c : T.SplitCur) -> \(c : T.EntryCurGetter) ->
\(a : T.SplitAcnt) -> \(a : T.EntryAcntGetter) ->
\(comment : Text) -> \(comment : Text) ->
\(ss : List PartSplit) -> \(ss : List PartSplit) ->
let toSplit = let toSplit =
\(x : PartSplit) -> \(x : PartSplit) ->
nullSplit (T.SplitAcnt.ConstT x._1) c nullSplit (T.EntryAcntGetter.ConstT x._1) c
// { sValue = Some (T.SplitNum.ConstN x._2), sComment = x._3 } // { eValue = Some (T.EntryNumGetter.ConstN x._2)
, eComment = x._3
}
in [ nullSplit a c // { sComment = comment } ] in [ nullSplit a c // { eComment = comment } ]
# List/map PartSplit T.ExpSplit.Type toSplit ss # List/map PartSplit T.EntryGetter.Type toSplit ss
let part1 = let part1 =
\(c : T.SplitCur) -> \(c : T.EntryCurGetter) ->
\(a : T.SplitAcnt) -> \(a : T.EntryAcntGetter) ->
\(comment : Text) -> \(comment : Text) ->
partN c a comment ([] : List PartSplit) partN c a comment ([] : List PartSplit)
let part1_ = let part1_ =
\(c : T.SplitCur) -> \(c : T.EntryCurGetter) ->
\(a : T.SplitAcnt) -> \(a : T.EntryAcntGetter) ->
partN c a "" ([] : List PartSplit) partN c a "" ([] : List PartSplit)
let addDay = let addDay =
@ -130,21 +119,21 @@ let addDay =
\(d : Natural) -> \(d : Natural) ->
{ gYear = x.gmYear, gMonth = x.gmMonth, gDay = d } { 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 in { nullSplit
, nullMatch , nullMatch
@ -182,9 +171,5 @@ in { nullSplit
, mvDenP , mvDenP
, mvDenN , mvDenN
, PartSplit , PartSplit
, d
, d_
, dec
, dec2
} }
/\ T /\ T

View File

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

View File

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

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
]

View File

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

View File

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

View File

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

View File

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