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
|
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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 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
|
||||||
|
|
|
@ -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
|
@ -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 (: []))
|
||||||
|
|
|
@ -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 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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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/
|
||||||
|
|
|
@ -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: []
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue