ENH use normal years in dates
This commit is contained in:
parent
b2e6047800
commit
f9c1e36ee8
11
app/Main.hs
11
app/Main.hs
|
@ -157,14 +157,9 @@ runDumpAccountKeys c = do
|
||||||
runSync :: MonadUnliftIO m => FilePath -> m ()
|
runSync :: MonadUnliftIO m => FilePath -> m ()
|
||||||
runSync c = do
|
runSync c = do
|
||||||
config <- readConfig c
|
config <- readConfig c
|
||||||
catch (sync_ config) $ \case
|
migrate_ (sqlConfig config) $ do
|
||||||
InsertException _ -> liftIO $ putStrLn "insert error"
|
s <- getDBState config
|
||||||
where
|
flip runReaderT (s $ takeDirectory c) $ do
|
||||||
sync_ config = migrate_ (sqlConfig config) $ do
|
|
||||||
res <- getDBState config
|
|
||||||
case res of
|
|
||||||
Left es -> throwIO $ InsertException es
|
|
||||||
Right s -> flip runReaderT (s $ takeDirectory c) $ do
|
|
||||||
es1 <- insertBudget $ budget config
|
es1 <- insertBudget $ budget config
|
||||||
es2 <- insertStatements config
|
es2 <- insertStatements config
|
||||||
let es = es1 ++ es2
|
let es = es1 ++ es2
|
||||||
|
|
|
@ -306,12 +306,8 @@ indexAcntRoot r =
|
||||||
getDBState
|
getDBState
|
||||||
:: MonadUnliftIO m
|
:: MonadUnliftIO m
|
||||||
=> Config
|
=> Config
|
||||||
-> SqlPersistT m (EitherErrs (FilePath -> DBState))
|
-> SqlPersistT m (FilePath -> DBState)
|
||||||
getDBState c = mapM (uncurry go) $ concatEithers2 bi si (,)
|
getDBState c = do
|
||||||
where
|
|
||||||
bi = intervalMaybeBounds $ budgetInterval $ global c
|
|
||||||
si = intervalMaybeBounds $ statementInterval $ global c
|
|
||||||
go budgetInt statementInt = do
|
|
||||||
am <- updateAccounts $ accounts c
|
am <- updateAccounts $ accounts c
|
||||||
cm <- updateCurrencies $ currencies c
|
cm <- updateCurrencies $ currencies c
|
||||||
hs <- updateHashes c
|
hs <- updateHashes c
|
||||||
|
@ -321,8 +317,8 @@ getDBState c = mapM (uncurry go) $ concatEithers2 bi si (,)
|
||||||
DBState
|
DBState
|
||||||
{ kmCurrency = cm
|
{ kmCurrency = cm
|
||||||
, kmAccount = am
|
, kmAccount = am
|
||||||
, kmBudgetInterval = budgetInt
|
, kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c
|
||||||
, kmStatementInterval = statementInt
|
, kmStatementInterval = intervalMaybeBounds $ statementInterval $ global c
|
||||||
, kmNewCommits = hs
|
, kmNewCommits = hs
|
||||||
, kmConfigDir = f
|
, kmConfigDir = f
|
||||||
}
|
}
|
||||||
|
|
|
@ -8,7 +8,6 @@ module Internal.Insert
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Bitraversable
|
|
||||||
import Data.Hashable
|
import Data.Hashable
|
||||||
import Database.Persist.Class
|
import Database.Persist.Class
|
||||||
import Database.Persist.Sql hiding (Single, Statement)
|
import Database.Persist.Sql hiding (Single, Statement)
|
||||||
|
@ -49,21 +48,19 @@ lookupCurrency c = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- intervals
|
-- intervals
|
||||||
|
|
||||||
expandDatePat :: Bounds -> DatePat -> EitherErr [Day]
|
expandDatePat :: Bounds -> DatePat -> [Day]
|
||||||
expandDatePat (a, b) (Cron cp) = return $ filter (cronPatternMatches cp) [a .. b]
|
expandDatePat (a, b) (Cron cp) = filter (cronPatternMatches cp) [a .. b]
|
||||||
expandDatePat i (Mod mp) = expandModPat mp i
|
expandDatePat i (Mod mp) = expandModPat mp i
|
||||||
|
|
||||||
expandModPat :: ModPat -> Bounds -> EitherErr [Day]
|
expandModPat :: ModPat -> Bounds -> [Day]
|
||||||
expandModPat
|
expandModPat
|
||||||
ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r}
|
ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r}
|
||||||
(lower, upper) = do
|
(lower, upper) =
|
||||||
start <- maybe (return lower) fromGregorian' s
|
|
||||||
return $
|
|
||||||
takeWhile (<= upper) $
|
takeWhile (<= upper) $
|
||||||
(`addFun` start) . (* b')
|
(`addFun` start) . (* b')
|
||||||
<$> maybe id (take . fromIntegral) r [0 ..]
|
<$> maybe id (take . fromIntegral) r [0 ..]
|
||||||
where
|
where
|
||||||
-- start = maybe lower fromGregorian' s
|
start = maybe lower fromGregorian' s
|
||||||
b' = fromIntegral b
|
b' = fromIntegral b
|
||||||
addFun = case u of
|
addFun = case u of
|
||||||
Day -> addDays
|
Day -> addDays
|
||||||
|
@ -121,9 +118,8 @@ mdyPatternMatches check x p = case p of
|
||||||
|
|
||||||
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
|
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
|
||||||
insertBudget Budget {income = is, expenses = es} = do
|
insertBudget Budget {income = is, expenses = es} = do
|
||||||
es1 <- mapM insertIncome is
|
mapM_ insertExpense es
|
||||||
es2 <- mapM insertExpense es
|
concat <$> mapM insertIncome is
|
||||||
return $ concat $ es1 ++ es2
|
|
||||||
|
|
||||||
-- TODO this hashes twice (not that it really matters)
|
-- TODO this hashes twice (not that it really matters)
|
||||||
whenHash
|
whenHash
|
||||||
|
@ -148,23 +144,21 @@ insertIncome
|
||||||
} =
|
} =
|
||||||
whenHash CTIncome i [] $ \c -> do
|
whenHash CTIncome i [] $ \c -> do
|
||||||
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
||||||
case (balanceIncome i, expandDatePat bounds dp) of
|
unlessLeft (balanceIncome i) $ \balanced -> do
|
||||||
(Right balanced, Right days) -> do
|
forM_ (expandDatePat bounds dp) $ \day -> do
|
||||||
forM_ days $ \day -> do
|
|
||||||
alloTx <- concat <$> mapM (allocationToTx from day) balanced
|
alloTx <- concat <$> mapM (allocationToTx from day) balanced
|
||||||
taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts
|
taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts
|
||||||
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx
|
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx
|
||||||
return []
|
|
||||||
(a, b) -> return $ catMaybes [leftToMaybe a, leftToMaybe b]
|
|
||||||
|
|
||||||
balanceIncome :: Income -> EitherErr [BalAllocation]
|
balanceIncome :: Income -> EitherErr [BalAllocation]
|
||||||
balanceIncome
|
balanceIncome
|
||||||
Income
|
Income
|
||||||
{ incGross = g
|
{ incGross = g
|
||||||
|
, incWhen = dp
|
||||||
, incPretax = pre
|
, incPretax = pre
|
||||||
, incTaxes = tax
|
, incTaxes = tax
|
||||||
, incPosttax = post
|
, incPosttax = post
|
||||||
} = (preRat ++) <$> balancePostTax bal postRat
|
} = (preRat ++) <$> balancePostTax dp bal postRat
|
||||||
where
|
where
|
||||||
preRat = mapAlloAmts dec2Rat <$> pre
|
preRat = mapAlloAmts dec2Rat <$> pre
|
||||||
postRat = mapAlloAmts (fmap dec2Rat) <$> post
|
postRat = mapAlloAmts (fmap dec2Rat) <$> post
|
||||||
|
@ -235,7 +229,7 @@ transferToTx
|
||||||
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
|
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
|
||||||
txPair day from to cur v d
|
txPair day from to cur v d
|
||||||
|
|
||||||
insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError]
|
insertExpense :: MonadUnliftIO m => Expense -> MappingT m ()
|
||||||
insertExpense
|
insertExpense
|
||||||
e@Expense
|
e@Expense
|
||||||
{ expFrom = from
|
{ expFrom = from
|
||||||
|
@ -244,12 +238,11 @@ insertExpense
|
||||||
, expBucket = buc
|
, expBucket = buc
|
||||||
, expAmounts = as
|
, expAmounts = as
|
||||||
} = do
|
} = do
|
||||||
whenHash CTExpense e [] $ \key -> concat <$> mapM (go key) as
|
whenHash CTExpense e () $ \key -> mapM_ (go key) as
|
||||||
where
|
where
|
||||||
go key amt = do
|
go key amt = do
|
||||||
res <- timeAmountToTx from to cur amt
|
keys <- timeAmountToTx from to cur amt
|
||||||
unlessLeft res $
|
lift $ mapM_ (insertTxBucket (Just buc) key) keys
|
||||||
lift . mapM_ (insertTxBucket (Just buc) key)
|
|
||||||
|
|
||||||
timeAmountToTx
|
timeAmountToTx
|
||||||
:: MonadUnliftIO m
|
:: MonadUnliftIO m
|
||||||
|
@ -257,7 +250,7 @@ timeAmountToTx
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> CurID
|
-> CurID
|
||||||
-> TimeAmount
|
-> TimeAmount
|
||||||
-> MappingT m (EitherErr [KeyTx])
|
-> MappingT m [KeyTx]
|
||||||
timeAmountToTx
|
timeAmountToTx
|
||||||
from
|
from
|
||||||
to
|
to
|
||||||
|
@ -271,7 +264,7 @@ timeAmountToTx
|
||||||
}
|
}
|
||||||
} = do
|
} = do
|
||||||
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
||||||
bimapM return (mapM tx) $ expandDatePat bounds dp
|
mapM tx $ expandDatePat bounds dp
|
||||||
where
|
where
|
||||||
tx day = txPair day from to cur (dec2Rat v) d
|
tx day = txPair day from to cur (dec2Rat v) d
|
||||||
|
|
||||||
|
@ -284,10 +277,10 @@ insertStatements conf = concat <$> mapM insertStatement (statements conf)
|
||||||
-- unless (null es) $ throwIO $ InsertException es
|
-- unless (null es) $ throwIO $ InsertException es
|
||||||
|
|
||||||
insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
|
insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
|
||||||
insertStatement (StmtManual m) = insertManual m
|
insertStatement (StmtManual m) = insertManual m >> return []
|
||||||
insertStatement (StmtImport i) = insertImport i
|
insertStatement (StmtImport i) = insertImport i
|
||||||
|
|
||||||
insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError]
|
insertManual :: MonadUnliftIO m => Manual -> MappingT m ()
|
||||||
insertManual
|
insertManual
|
||||||
m@Manual
|
m@Manual
|
||||||
{ manualDate = dp
|
{ manualDate = dp
|
||||||
|
@ -297,10 +290,9 @@ insertManual
|
||||||
, manualCurrency = u
|
, manualCurrency = u
|
||||||
, manualDesc = e
|
, manualDesc = e
|
||||||
} = do
|
} = do
|
||||||
whenHash CTManual m [] $ \c -> do
|
whenHash CTManual m () $ \c -> do
|
||||||
bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
|
bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
|
||||||
unlessLeft (expandDatePat bounds dp) $ \days -> do
|
ts <- mapM tx $ expandDatePat bounds dp
|
||||||
ts <- mapM tx days
|
|
||||||
lift $ mapM_ (insertTx c) ts
|
lift $ mapM_ (insertTx c) ts
|
||||||
where
|
where
|
||||||
tx day = txPair day from to u (dec2Rat v) e
|
tx day = txPair day from to u (dec2Rat v) e
|
||||||
|
|
|
@ -102,27 +102,24 @@ recoverZipper :: Zipped a -> [a]
|
||||||
recoverZipper (Zipped as bs) = reverse as ++ bs
|
recoverZipper (Zipped as bs) = reverse as ++ bs
|
||||||
|
|
||||||
zipperSlice
|
zipperSlice
|
||||||
:: Monad m
|
:: (a -> b -> Ordering)
|
||||||
=> (a -> b -> m Ordering)
|
|
||||||
-> b
|
-> b
|
||||||
-> Zipped a
|
-> Zipped a
|
||||||
-> m (Either (Zipped a) (Unzipped a))
|
-> Either (Zipped a) (Unzipped a)
|
||||||
zipperSlice f x = go
|
zipperSlice f x = go
|
||||||
where
|
where
|
||||||
go z@(Zipped _ []) = return $ Left z
|
go z@(Zipped _ []) = Left z
|
||||||
go z@(Zipped bs (a : as)) = do
|
go z@(Zipped bs (a : as)) =
|
||||||
res <- f a x
|
case f a x of
|
||||||
case res of
|
|
||||||
GT -> go $ Zipped (a : bs) as
|
GT -> go $ Zipped (a : bs) as
|
||||||
EQ -> Right <$> goEq (Unzipped bs [a] as)
|
EQ -> Right $ goEq (Unzipped bs [a] as)
|
||||||
LT -> return $ Left z
|
LT -> Left z
|
||||||
goEq z@(Unzipped _ _ []) = return z
|
goEq z@(Unzipped _ _ []) = z
|
||||||
goEq z@(Unzipped bs cs (a : as)) = do
|
goEq z@(Unzipped bs cs (a : as)) =
|
||||||
res <- f a x
|
case f a x of
|
||||||
case res of
|
|
||||||
GT -> goEq $ Unzipped (a : bs) cs as
|
GT -> goEq $ Unzipped (a : bs) cs as
|
||||||
EQ -> goEq $ Unzipped bs (a : cs) as
|
EQ -> goEq $ Unzipped bs (a : cs) as
|
||||||
LT -> return z
|
LT -> z
|
||||||
|
|
||||||
zipperMatch :: Unzipped Match -> TxRecord -> EitherErrs (Zipped Match, MatchRes RawTx)
|
zipperMatch :: Unzipped Match -> TxRecord -> EitherErrs (Zipped Match, MatchRes RawTx)
|
||||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||||
|
@ -178,9 +175,8 @@ matchDates ms = go ([], [], initZipper ms)
|
||||||
, reverse unmatched
|
, reverse unmatched
|
||||||
, recoverZipper z
|
, recoverZipper z
|
||||||
)
|
)
|
||||||
go (matched, unmatched, z) (r : rs) = do
|
go (matched, unmatched, z) (r : rs) =
|
||||||
sliced <- zipperSlice findDate r z
|
case zipperSlice findDate r z of
|
||||||
case sliced of
|
|
||||||
Left zipped -> go (matched, r : unmatched, zipped) rs
|
Left zipped -> go (matched, r : unmatched, zipped) rs
|
||||||
Right unzipped -> do
|
Right unzipped -> do
|
||||||
(z', res) <- zipperMatch unzipped r
|
(z', res) <- zipperMatch unzipped r
|
||||||
|
@ -189,7 +185,7 @@ matchDates ms = go ([], [], initZipper ms)
|
||||||
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 (Right EQ) (first (: []) . (`compareDate` trDate r)) $ mDate m
|
findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
|
||||||
|
|
||||||
matchNonDates :: [Match] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [Match])
|
matchNonDates :: [Match] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [Match])
|
||||||
matchNonDates ms = go ([], [], initZipper ms)
|
matchNonDates ms = go ([], [], initZipper ms)
|
||||||
|
|
|
@ -540,8 +540,8 @@ data AllocationSuberr
|
||||||
|
|
||||||
data InsertError
|
data InsertError
|
||||||
= RegexError T.Text
|
= RegexError T.Text
|
||||||
| YearError MatchYMD
|
| -- | YearError MatchYMD
|
||||||
| ConversionError T.Text
|
ConversionError T.Text
|
||||||
| LookupError LookupSuberr T.Text
|
| LookupError LookupSuberr T.Text
|
||||||
| BalanceError BalanceType CurID [RawSplit]
|
| BalanceError BalanceType CurID [RawSplit]
|
||||||
| AllocationError AllocationSuberr DatePat
|
| AllocationError AllocationSuberr DatePat
|
||||||
|
|
|
@ -2,7 +2,25 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
module Internal.Utils where
|
module Internal.Utils
|
||||||
|
( compareDate
|
||||||
|
, intervalMaybeBounds
|
||||||
|
, fmtRational
|
||||||
|
, matches
|
||||||
|
, fromGregorian'
|
||||||
|
, resolveBounds
|
||||||
|
, leftToMaybe
|
||||||
|
, dec2Rat
|
||||||
|
, concatEithers2
|
||||||
|
, concatEither2
|
||||||
|
, parseRational
|
||||||
|
, showError
|
||||||
|
, unlessLeft
|
||||||
|
, unlessLefts
|
||||||
|
, inMaybeBounds
|
||||||
|
, acntPath2Text
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Time.Format.ISO8601
|
import Data.Time.Format.ISO8601
|
||||||
import GHC.Real
|
import GHC.Real
|
||||||
|
@ -15,49 +33,39 @@ import RIO.Time
|
||||||
import Text.Regex.TDFA
|
import Text.Regex.TDFA
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- gregorian
|
-- dates
|
||||||
|
|
||||||
gregTup :: Gregorian -> EitherErr (Integer, Int, Int)
|
gregTup :: Gregorian -> (Integer, Int, Int)
|
||||||
gregTup g@Gregorian {..}
|
gregTup Gregorian {..} =
|
||||||
| gYear > 99 = Left $ YearError $ YMD g
|
( fromIntegral gYear
|
||||||
| otherwise =
|
|
||||||
return
|
|
||||||
( fromIntegral gYear + 2000
|
|
||||||
, fromIntegral gMonth
|
, fromIntegral gMonth
|
||||||
, fromIntegral gDay
|
, fromIntegral gDay
|
||||||
)
|
)
|
||||||
|
|
||||||
gregMTup :: GregorianM -> EitherErr (Integer, Int)
|
gregMTup :: GregorianM -> (Integer, Int)
|
||||||
gregMTup g@GregorianM {..}
|
gregMTup GregorianM {..} =
|
||||||
| gmYear > 99 = Left $ YearError $ YM g
|
( fromIntegral gmYear
|
||||||
| otherwise =
|
|
||||||
return
|
|
||||||
( fromIntegral gmYear + 2000
|
|
||||||
, fromIntegral gmMonth
|
, fromIntegral gmMonth
|
||||||
)
|
)
|
||||||
|
|
||||||
data MDY_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int
|
data YMD_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int
|
||||||
|
|
||||||
fromMatchYMD :: MatchYMD -> EitherErr MDY_
|
fromMatchYMD :: MatchYMD -> YMD_
|
||||||
fromMatchYMD m = case m of
|
fromMatchYMD m = case m of
|
||||||
Y y
|
Y y -> Y_ $ fromIntegral y
|
||||||
| y > 99 -> Left $ YearError $ Y y
|
YM g -> uncurry YM_ $ gregMTup g
|
||||||
| otherwise -> Right $ Y_ $ fromIntegral y + 2000
|
YMD g -> uncurry3 YMD_ $ gregTup g
|
||||||
YM g -> uncurry YM_ <$> gregMTup g
|
|
||||||
YMD g -> uncurry3 YMD_ <$> gregTup g
|
|
||||||
|
|
||||||
compareDate :: MatchDate -> Day -> EitherErr Ordering
|
compareDate :: MatchDate -> Day -> Ordering
|
||||||
compareDate (On md) x = do
|
compareDate (On md) x =
|
||||||
res <- fromMatchYMD md
|
case fromMatchYMD md of
|
||||||
return $ case res 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
|
||||||
res <- fromMatchYMD md
|
case fromMatchYMD md of
|
||||||
return $ case res 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' ->
|
||||||
|
@ -70,26 +78,21 @@ compareDate (In md offset) x = do
|
||||||
| otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
|
| otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
|
||||||
toMonth year month = (year * 12) + fromIntegral month
|
toMonth year month = (year * 12) + fromIntegral month
|
||||||
|
|
||||||
boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErrs Bounds
|
-- boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds
|
||||||
boundsFromGregorian (a, b) = concatEither2 a_ b_ (,)
|
-- boundsFromGregorian (a, b) = (fromGregorian' a, fromGregorian' b)
|
||||||
where
|
|
||||||
a_ = fromGregorian' a
|
|
||||||
b_ = fromGregorian' b
|
|
||||||
|
|
||||||
fromGregorian' :: Gregorian -> EitherErr Day
|
fromGregorian' :: Gregorian -> Day
|
||||||
fromGregorian' = fmap (uncurry3 fromGregorian) . gregTup
|
fromGregorian' = uncurry3 fromGregorian . gregTup
|
||||||
|
|
||||||
inBounds :: Bounds -> Day -> Bool
|
-- inBounds :: Bounds -> Day -> Bool
|
||||||
inBounds (d0, d1) x = d0 <= x && x <= d1
|
-- inBounds (d0, d1) x = d0 <= x && x <= d1
|
||||||
|
|
||||||
inMaybeBounds :: MaybeBounds -> Day -> Bool
|
inMaybeBounds :: MaybeBounds -> Day -> Bool
|
||||||
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
|
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
|
||||||
|
|
||||||
intervalMaybeBounds :: Interval -> EitherErrs MaybeBounds
|
intervalMaybeBounds :: Interval -> MaybeBounds
|
||||||
intervalMaybeBounds Interval {intStart = s, intEnd = e} = concatEither2 s_ e_ (,)
|
intervalMaybeBounds Interval {intStart = s, intEnd = e} =
|
||||||
where
|
(fmap fromGregorian' s, fmap fromGregorian' e)
|
||||||
s_ = mapM fromGregorian' s
|
|
||||||
e_ = mapM fromGregorian' e
|
|
||||||
|
|
||||||
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
|
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
|
||||||
resolveBounds (s, e) = do
|
resolveBounds (s, e) = do
|
||||||
|
@ -104,13 +107,13 @@ resolveBounds (s, e) = do
|
||||||
|
|
||||||
matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx)
|
matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx)
|
||||||
matches Match {..} r@TxRecord {..} = do
|
matches Match {..} r@TxRecord {..} = do
|
||||||
res <- concatEither3 date other desc (\x y z -> x && y && z)
|
res <- concatEither2 other desc (&&)
|
||||||
if val && res
|
if date && val && res
|
||||||
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
|
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
|
||||||
else Right MatchFail
|
else Right MatchFail
|
||||||
where
|
where
|
||||||
val = valMatches mVal trAmount
|
val = valMatches mVal trAmount
|
||||||
date = maybe (Right True) (`dateMatches` trDate) mDate
|
date = maybe True (`dateMatches` trDate) mDate
|
||||||
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
|
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
|
||||||
desc = maybe (return True) (matchMaybe trDesc) mDesc
|
desc = maybe (return True) (matchMaybe trDesc) mDesc
|
||||||
convert (ToTx cur a ss) = toTx cur a ss r
|
convert (ToTx cur a ss) = toTx cur a ss r
|
||||||
|
@ -146,8 +149,8 @@ valMatches MatchVal {..} x =
|
||||||
s = signum x >= 0
|
s = signum x >= 0
|
||||||
checkMaybe = maybe True
|
checkMaybe = maybe True
|
||||||
|
|
||||||
dateMatches :: MatchDate -> Day -> EitherErr Bool
|
dateMatches :: MatchDate -> Day -> Bool
|
||||||
dateMatches md = fmap (EQ ==) . compareDate md
|
dateMatches md = (EQ ==) . compareDate md
|
||||||
|
|
||||||
otherMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr Bool
|
otherMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr Bool
|
||||||
otherMatches dict m = case m of
|
otherMatches dict m = case m of
|
||||||
|
@ -243,8 +246,8 @@ readRational s = case T.split (== '.') s of
|
||||||
err = Left $ ConversionError s
|
err = Left $ 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
|
||||||
mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
|
-- mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
|
||||||
|
|
||||||
fmtRational :: Natural -> Rational -> T.Text
|
fmtRational :: Natural -> Rational -> T.Text
|
||||||
fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
|
fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
|
||||||
|
@ -272,9 +275,6 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
|
||||||
showError :: InsertError -> [T.Text]
|
showError :: InsertError -> [T.Text]
|
||||||
showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms)
|
showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms)
|
||||||
showError other = (: []) $ case other of
|
showError other = (: []) $ case other of
|
||||||
-- TODO show whole date here since this is kinda useless
|
|
||||||
(YearError d) ->
|
|
||||||
T.append "Year must be two digits in " $ singleQuote $ showMatchYMD d
|
|
||||||
(RegexError re) -> T.append "could not make regex from pattern: " re
|
(RegexError re) -> T.append "could not make regex from pattern: " re
|
||||||
(ConversionError x) -> T.append "Could not convert to rational number: " x
|
(ConversionError x) -> T.append "Could not convert to rational number: " x
|
||||||
-- TODO use the field indicator
|
-- TODO use the field indicator
|
||||||
|
@ -348,49 +348,40 @@ showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriori
|
||||||
xs -> Just $ T.concat $ showMatchOther <$> xs
|
xs -> Just $ T.concat $ showMatchOther <$> xs
|
||||||
|
|
||||||
-- | Convert match date to text
|
-- | Convert match date to text
|
||||||
-- This will not throw errors even if year is > 99. Single date matches will
|
-- Single date matches will just show the single date, and ranged matches will
|
||||||
-- just show the single date, and ranged matches will show an interval like
|
-- show an interval like [YY-MM-DD, YY-MM-DD)
|
||||||
-- [YY-MM-DD, YY-MM-DD)
|
|
||||||
showMatchDate :: MatchDate -> T.Text
|
showMatchDate :: MatchDate -> T.Text
|
||||||
showMatchDate md = case md of
|
showMatchDate md = case md of
|
||||||
(On x) -> showMatchYMD x
|
(On x) -> showMatchYMD x
|
||||||
(In start n) -> T.concat ["[", showMatchYMD start, " ", showMatchYMD end, ")"]
|
(In start n) -> T.concat ["[", showMatchYMD start, " ", showYMD_ end, ")"]
|
||||||
where
|
where
|
||||||
end = case start of
|
-- TODO not DRY (this shifting thing happens during the comparison
|
||||||
(Y y) -> Y $ y + n
|
-- function (kinda)
|
||||||
(YM (GregorianM {..})) ->
|
end = case fromMatchYMD start of
|
||||||
let (y, m) = divMod (gmMonth + n - 1) 12
|
Y_ y -> Y_ $ y + fromIntegral n
|
||||||
in YM $
|
YM_ y m ->
|
||||||
GregorianM
|
let (y_, m_) = divMod (m + fromIntegral n - 1) 12
|
||||||
{ gmYear = gmYear + y
|
in YM_ (y + fromIntegral y_) (m + m_ + 1)
|
||||||
, gmMonth = gmMonth + m + 1
|
YMD_ y m d ->
|
||||||
}
|
uncurry3 YMD_ $
|
||||||
(YMD (Gregorian {..})) ->
|
|
||||||
let (y, m, d) =
|
|
||||||
toGregorian $
|
toGregorian $
|
||||||
addDays (fromIntegral n) $
|
addDays (fromIntegral n) $
|
||||||
fromGregorian
|
fromGregorian y m d
|
||||||
(fromIntegral gYear)
|
|
||||||
(fromIntegral gMonth)
|
|
||||||
(fromIntegral gDay)
|
|
||||||
in YMD $
|
|
||||||
Gregorian
|
|
||||||
{ gYear = fromIntegral y
|
|
||||||
, gMonth = fromIntegral m
|
|
||||||
, gDay = fromIntegral d
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | convert YMD match to text
|
-- | convert YMD match to text
|
||||||
-- this will not throw errors even if year is > 99
|
|
||||||
showMatchYMD :: MatchYMD -> T.Text
|
showMatchYMD :: MatchYMD -> T.Text
|
||||||
showMatchYMD md =
|
showMatchYMD = showYMD_ . fromMatchYMD
|
||||||
|
|
||||||
|
showYMD_ :: YMD_ -> T.Text
|
||||||
|
showYMD_ md =
|
||||||
T.intercalate "-" $ L.take 3 (fmap showT digits ++ L.repeat "*")
|
T.intercalate "-" $ L.take 3 (fmap showT digits ++ L.repeat "*")
|
||||||
where
|
where
|
||||||
digits = case md of
|
digits = case md of
|
||||||
Y y -> [y]
|
Y_ y -> [fromIntegral y]
|
||||||
YM (GregorianM {..}) -> [gmYear, gmMonth]
|
YM_ y m -> [fromIntegral y, m]
|
||||||
YMD (Gregorian {..}) -> [gYear, gMonth, gDay]
|
YMD_ y m d -> [fromIntegral y, m, d]
|
||||||
|
|
||||||
|
-- TODO there are errors that can be thrown here
|
||||||
showMatchVal :: MatchVal -> Maybe T.Text
|
showMatchVal :: MatchVal -> Maybe T.Text
|
||||||
showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
|
showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
|
||||||
showMatchVal MatchVal {..} = Just $ T.concat [sign, num, ".", den]
|
showMatchVal MatchVal {..} = Just $ T.concat [sign, num, ".", den]
|
||||||
|
@ -436,21 +427,21 @@ 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]
|
||||||
|
|
||||||
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
|
||||||
|
|
||||||
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
|
||||||
|
@ -482,17 +473,17 @@ merge = first concat
|
||||||
-- random functions
|
-- random functions
|
||||||
|
|
||||||
-- when bifunctor fails...
|
-- when bifunctor fails...
|
||||||
thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
|
-- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
|
||||||
thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
|
-- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
|
||||||
|
|
||||||
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
|
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
|
||||||
uncurry3 f (a, b, c) = f a b c
|
uncurry3 f (a, b, c) = f a b c
|
||||||
|
|
||||||
lpad :: a -> Int -> [a] -> [a]
|
-- lpad :: a -> Int -> [a] -> [a]
|
||||||
lpad c n s = replicate (n - length s) c ++ s
|
-- lpad c n s = replicate (n - length s) c ++ s
|
||||||
|
|
||||||
rpad :: a -> Int -> [a] -> [a]
|
-- rpad :: a -> Int -> [a] -> [a]
|
||||||
rpad c n s = s ++ replicate (n - length s) c
|
-- rpad c n s = s ++ replicate (n - length s) c
|
||||||
|
|
||||||
lpadT :: Char -> Int -> T.Text -> T.Text
|
lpadT :: Char -> Int -> T.Text -> T.Text
|
||||||
lpadT c n s = T.append (T.replicate (n - T.length s) (T.singleton c)) s
|
lpadT c n s = T.append (T.replicate (n - T.length s) (T.singleton c)) s
|
||||||
|
|
Loading…
Reference in New Issue