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

WIP use pure errors everywhere

This commit is contained in:
Nathan Dwarshuis 2023-01-25 23:04:54 -05:00
parent 0d0c961f1a
commit fc6cde2716
6 changed files with 247 additions and 196 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
app/Main.hs
View File

@ -158,13 +158,16 @@ runSync :: MonadUnliftIO m => FilePath -> m ()
runSync c = do
config <- readConfig c
catch (sync_ config) $ \case
MatchException -> liftIO $ putStrLn "match error"
RegexException -> liftIO $ putStrLn "regex error"
InsertException _ -> liftIO $ putStrLn "insert error"
where
sync_ config = migrate_ (sqlConfig config) $ do
s <- getDBState config
flip runReaderT (s $ takeDirectory c) $ do
insertBudget $ budget config
insertStatements config
res <- getDBState config
case res of
Left e -> throwIO $ InsertException [e]
Right s -> flip runReaderT (s $ takeDirectory c) $ do
es1 <- insertBudget $ budget config
es2 <- insertStatements config
let es = es1 ++ es2
unless (null es) $ throwIO $ InsertException es
-- showBalances

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

@ -302,19 +302,28 @@ indexAcntRoot r =
where
(ars, aprs, ms) = unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
getDBState :: MonadUnliftIO m => Config -> SqlPersistT m (FilePath -> DBState)
getDBState c = do
am <- updateAccounts $ accounts c
cm <- updateCurrencies $ currencies c
hs <- updateHashes c
-- TODO not sure how I feel about this, probably will change this struct alot
-- in the future so whatever...for now
return $ \f ->
DBState
{ kmCurrency = cm
, kmAccount = am
, kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c
, kmStatementInterval = intervalMaybeBounds $ statementInterval $ global c
, kmNewCommits = hs
, kmConfigDir = f
}
getDBState
:: MonadUnliftIO m
=> Config
-> SqlPersistT m (EitherErr (FilePath -> DBState))
getDBState c = mapM (uncurry go) intervals
where
intervals = do
b <- intervalMaybeBounds $ budgetInterval $ global c
s <- intervalMaybeBounds $ statementInterval $ global c
return (b, s)
go budgetInt statementInt = do
am <- updateAccounts $ accounts c
cm <- updateCurrencies $ currencies c
hs <- updateHashes c
-- TODO not sure how I feel about this, probably will change this struct alot
-- in the future so whatever...for now
return $ \f ->
DBState
{ kmCurrency = cm
, kmAccount = am
, kmBudgetInterval = budgetInt
, kmStatementInterval = statementInt
, kmNewCommits = hs
, kmConfigDir = f
}

94
lib/Internal/Insert.hs
View File

@ -48,24 +48,21 @@ lookupCurrency c = do
--------------------------------------------------------------------------------
-- intervals
expandDatePat :: Bounds -> DatePat -> [Day]
expandDatePat (a, b) (Cron cp) = filter (cronPatternMatches cp) [a .. b]
expandDatePat :: Bounds -> DatePat -> EitherErr [Day]
expandDatePat (a, b) (Cron cp) = return $ filter (cronPatternMatches cp) [a .. b]
expandDatePat i (Mod mp) = expandModPat mp i
expandModPat :: ModPat -> Bounds -> [Day]
expandModPat :: ModPat -> Bounds -> EitherErr [Day]
expandModPat
ModPat
{ mpStart = s
, mpBy = b
, mpUnit = u
, mpRepeats = r
}
(lower, upper) =
takeWhile (<= upper) $
(`addFun` start) . (* b')
<$> maybe id (take . fromIntegral) r [0 ..]
ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r}
(lower, upper) = do
start <- maybe (return lower) fromGregorian' s
return $
takeWhile (<= upper) $
(`addFun` start) . (* b')
<$> maybe id (take . fromIntegral) r [0 ..]
where
start = maybe lower fromGregorian' s
-- start = maybe lower fromGregorian' s
b' = fromIntegral b
addFun = case u of
Day -> addDays
@ -121,10 +118,11 @@ mdyPatternMatches check x p = case p of
--------------------------------------------------------------------------------
-- budget
insertBudget :: MonadUnliftIO m => Budget -> MappingT m ()
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
insertBudget Budget {income = is, expenses = es} = do
mapM_ insertIncome is
mapM_ insertExpense es
es1 <- mapM insertIncome is
es2 <- mapM insertExpense es
return $ catMaybes es1 ++ concat es2
-- TODO this hashes twice (not that it really matters)
whenHash
@ -139,7 +137,7 @@ whenHash t o def f = do
hs <- asks kmNewCommits
if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def
insertIncome :: MonadUnliftIO m => Income -> MappingT m ()
insertIncome :: MonadUnliftIO m => Income -> MappingT m (Maybe InsertError)
insertIncome
i@Income
{ incCurrency = cur
@ -147,15 +145,19 @@ insertIncome
, incAccount = from
, incTaxes = ts
} =
whenHash CTIncome i () $ \c -> do
whenHash CTIncome i Nothing $ \c -> do
case balanceIncome i of
Left m -> liftIO $ print m
Left m -> liftIO $ print m >> return Nothing
Right as -> do
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
forM_ (expandDatePat bounds dp) $ \day -> do
alloTx <- concat <$> mapM (allocationToTx from day) as
taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx
case expandDatePat bounds dp of
Left e -> return $ Just e
Right days -> do
forM_ days $ \day -> do
alloTx <- concat <$> mapM (allocationToTx from day) as
taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx
return Nothing
balanceIncome :: Income -> Either T.Text [BalAllocation]
balanceIncome
@ -234,7 +236,7 @@ transferToTx
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
txPair day from to cur v d
insertExpense :: MonadUnliftIO m => Expense -> MappingT m ()
insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError]
insertExpense
e@Expense
{ expFrom = from
@ -243,17 +245,23 @@ insertExpense
, expBucket = buc
, expAmounts = as
} = do
whenHash CTExpense e () $ \c -> do
ts <- concat <$> mapM (timeAmountToTx from to cur) as
lift $ mapM_ (insertTxBucket (Just buc) c) ts
whenHash CTExpense e [] $ \key -> catMaybes <$> mapM (go key) as
where
go key amt = do
res <- timeAmountToTx from to cur amt
case res of
Left err -> return $ Just err
Right txs -> do
lift $ mapM_ (insertTxBucket (Just buc) key) txs
return Nothing
timeAmountToTx
:: MonadUnliftIO m
=> AcntID
-> AcntID
-> T.Text
-> CurID
-> TimeAmount
-> MappingT m [KeyTx]
-> MappingT m (EitherErr [KeyTx])
timeAmountToTx
from
to
@ -267,23 +275,25 @@ timeAmountToTx
}
} = do
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
mapM tx $ expandDatePat bounds dp
case expandDatePat bounds dp of
Left e -> return $ Left e
Right days -> Right <$> mapM tx days
where
tx day = txPair day from to cur (dec2Rat v) d
--------------------------------------------------------------------------------
-- statements
insertStatements :: MonadUnliftIO m => Config -> MappingT m ()
insertStatements conf = do
es <- catMaybes <$> mapM insertStatement (statements conf)
unless (null es) $ throwIO $ InsertException es
insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError]
insertStatements conf = catMaybes <$> mapM insertStatement (statements conf)
-- unless (null es) $ throwIO $ InsertException es
insertStatement :: MonadUnliftIO m => Statement -> MappingT m (Maybe InsertError)
insertStatement (StmtManual m) = insertManual m >> return Nothing
insertStatement (StmtManual m) = insertManual m
insertStatement (StmtImport i) = insertImport i
insertManual :: MonadUnliftIO m => Manual -> MappingT m ()
insertManual :: MonadUnliftIO m => Manual -> MappingT m (Maybe InsertError)
insertManual
m@Manual
{ manualDate = dp
@ -293,10 +303,14 @@ insertManual
, manualCurrency = u
, manualDesc = e
} = do
whenHash CTManual m () $ \c -> do
whenHash CTManual m Nothing $ \c -> do
bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
ts <- mapM tx $ expandDatePat bounds dp
lift $ mapM_ (insertTx c) ts
case expandDatePat bounds dp of
Left err -> return $ Just err
Right days -> do
ts <- mapM tx days
lift $ mapM_ (insertTx c) ts
return Nothing
where
tx day = txPair day from to u (dec2Rat v) e

48
lib/Internal/Statement.hs
View File

@ -100,19 +100,23 @@ resetZipper = initZipper . recoverZipper
recoverZipper :: Zipped a -> [a]
recoverZipper (Zipped as bs) = reverse as ++ bs
zipperSlice :: (a -> b -> Ordering) -> b -> Zipped a -> Either (Zipped a) (Unzipped a)
zipperSlice :: Monad m => (a -> b -> m Ordering) -> b -> Zipped a -> m (Either (Zipped a) (Unzipped a))
zipperSlice f x = go
where
go z@(Zipped _ []) = Left z
go z@(Zipped bs (a : as)) = case f a x of
GT -> go $ Zipped (a : bs) as
EQ -> Right $ goEq (Unzipped bs [a] as)
LT -> Left z
goEq z@(Unzipped _ _ []) = z
goEq z@(Unzipped bs cs (a : as)) = case f a x of
GT -> goEq $ Unzipped (a : bs) cs as
EQ -> goEq $ Unzipped bs (a : cs) as
LT -> z
go z@(Zipped _ []) = return $ Left z
go z@(Zipped bs (a : as)) = do
res <- f a x
case res of
GT -> go $ Zipped (a : bs) as
EQ -> Right <$> goEq (Unzipped bs [a] as)
LT -> return $ Left z
goEq z@(Unzipped _ _ []) = return z
goEq z@(Unzipped bs cs (a : as)) = do
res <- f a x
case res of
GT -> goEq $ Unzipped (a : bs) cs as
EQ -> goEq $ Unzipped bs (a : cs) as
LT -> return z
zipperMatch :: Unzipped Match -> TxRecord -> EitherErr (Zipped Match, MatchRes RawTx)
zipperMatch (Unzipped bs cs as) x = go [] cs
@ -168,16 +172,18 @@ matchDates ms = go ([], [], initZipper ms)
, reverse unmatched
, recoverZipper z
)
go (matched, unmatched, z) (r : rs) = case zipperSlice findDate r z of
Left zipped -> go (matched, r : unmatched, zipped) rs
Right unzipped -> do
(z', res) <- zipperMatch unzipped r
let (m, u) = case res of
MatchPass p -> (Just p : matched, unmatched)
MatchSkip -> (Nothing : matched, unmatched)
MatchFail -> (matched, r : unmatched)
go (m, u, z') rs
findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
go (matched, unmatched, z) (r : rs) = do
sliced <- zipperSlice findDate r z
case sliced of
Left zipped -> go (matched, r : unmatched, zipped) rs
Right unzipped -> do
(z', res) <- zipperMatch unzipped r
let (m, u) = case res of
MatchPass p -> (Just p : matched, unmatched)
MatchSkip -> (Nothing : matched, unmatched)
MatchFail -> (matched, r : unmatched)
go (m, u, z') rs
findDate m r = maybe (Right EQ) (`compareDate` trDate r) $ mDate m
matchNonDates :: [Match] -> [TxRecord] -> EitherErr ([RawTx], [TxRecord], [Match])
matchNonDates ms = go ([], [], initZipper ms)

7
lib/Internal/Types.hs
View File

@ -508,10 +508,15 @@ data MatchRes a = MatchPass a | MatchFail | MatchSkip
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
data LookupField = AccountField | CurrencyField | OtherField deriving (Show)
-- data ConversionSubError = Malformed | deriving (Show)
data InsertError
= RegexError T.Text
| YearError Natural
| ConversionError T.Text
| LookupError T.Text
| LookupError LookupField T.Text
| BalanceError BalanceType CurID [RawSplit]
| StatementError [TxRecord] [Match]
deriving (Show)

238
lib/Internal/Utils.hs
View File

@ -11,7 +11,6 @@ import RIO
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.Text as T
import qualified RIO.Text.Partial as TP
import RIO.Time
import Text.Regex.TDFA
@ -20,46 +19,52 @@ 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)
-- TODO get rid of these errors
gregTup :: Gregorian -> (Integer, Int, Int)
gregTup g@Gregorian {..}
| gYear > 99 = error $ show g ++ ": year must only be two digits"
gregTup :: Gregorian -> EitherErr (Integer, Int, Int)
gregTup Gregorian {..}
| gYear > 99 = Left $ YearError gYear
| otherwise =
( fromIntegral gYear + 2000
, fromIntegral gMonth
, fromIntegral gDay
)
return
( fromIntegral gYear + 2000
, fromIntegral gMonth
, fromIntegral gDay
)
gregMTup :: GregorianM -> (Integer, Int)
gregMTup g@GregorianM {..}
| gmYear > 99 = error $ show g ++ ": year must only be two digits"
gregMTup :: GregorianM -> EitherErr (Integer, Int)
gregMTup GregorianM {..}
| gmYear > 99 = Left $ YearError gmYear
| otherwise =
( fromIntegral gmYear + 2000
, fromIntegral gmMonth
)
return
( fromIntegral gmYear + 2000
, fromIntegral gmMonth
)
data MDY_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int
fromMatchYMD :: MatchYMD -> MDY_
fromMatchYMD :: MatchYMD -> EitherErr MDY_
fromMatchYMD m = case m of
Y y
| y > 99 -> error $ show m ++ ": year must only be two digits"
| otherwise -> Y_ $ fromIntegral y + 2000
YM g -> uncurry YM_ $ gregMTup g
YMD g -> uncurry3 YMD_ $ gregTup g
| y > 99 -> Left $ YearError y
| otherwise -> Right $ Y_ $ fromIntegral y + 2000
YM g -> uncurry YM_ <$> gregMTup g
YMD g -> uncurry3 YMD_ <$> gregTup g
compareDate :: MatchDate -> Day -> Ordering
compareDate (On md) x = case fromMatchYMD md of
Y_ y' -> compare y y'
YM_ y' m' -> compare (y, m) (y', m')
YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
compareDate :: MatchDate -> Day -> EitherErr Ordering
compareDate (On md) x = do
res <- fromMatchYMD md
return $ case res of
Y_ y' -> compare y y'
YM_ y' m' -> compare (y, m) (y', m')
YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
where
(y, m, d) = toGregorian x
compareDate (In md offset) x = case fromMatchYMD md of
Y_ y' -> compareRange y' y
YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
YMD_ y' m' d' ->
let s = toModifiedJulianDay $ fromGregorian y' m' d'
in compareRange s $ toModifiedJulianDay x
compareDate (In md offset) x = do
res <- fromMatchYMD md
return $ case res of
Y_ y' -> compareRange y' y
YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
YMD_ y' m' d' ->
let s = toModifiedJulianDay $ fromGregorian y' m' d'
in compareRange s $ toModifiedJulianDay x
where
(y, m, _) = toGregorian x
compareRange start z
@ -67,8 +72,8 @@ compareDate (In md offset) x = case fromMatchYMD md of
| otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
toMonth year month = (year * 12) + fromIntegral month
dateMatches :: MatchDate -> Day -> Bool
dateMatches md = (EQ ==) . compareDate md
dateMatches :: MatchDate -> Day -> EitherErr Bool
dateMatches md = fmap (EQ ==) . compareDate md
valMatches :: MatchVal -> Rational -> Bool
valMatches MatchVal {..} x =
@ -80,55 +85,57 @@ valMatches MatchVal {..} x =
p = 10 ^ mvPrec
s = signum x >= 0
evalSplit :: TxRecord -> ExpSplit -> RawSplit
evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
s
{ sAcnt = evalAcnt r a
, sValue = evalExp r =<< v
, sCurrency = evalCurrency r c
}
evalSplit :: TxRecord -> ExpSplit -> EitherErr RawSplit
evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} = do
a_ <- evalAcnt r a
v_ <- mapM (evalExp r) v
c_ <- evalCurrency r c
return (s {sAcnt = a_, sValue = v_, sCurrency = c_})
evalAcnt :: TxRecord -> SplitAcnt -> T.Text
evalAcnt :: TxRecord -> SplitAcnt -> EitherErr T.Text
evalAcnt TxRecord {trOther = o} s = case s of
ConstT p -> p
LookupT f -> read $ T.unpack $ lookupField f o
MapT (Field f m) -> let k = lookupField f o in lookupErr "account key" k m
Map2T (Field (f1, f2) m) ->
let k1 = lookupField f1 o
k2 = lookupField f2 o
in lookupErr "account key" (k1, k2) m
ConstT p -> Right p
LookupT f -> lookupErr AccountField f o
MapT (Field f m) -> do
k <- lookupErr AccountField f o
lookupErr AccountField k m
Map2T (Field (f1, f2) m) -> do
k1 <- lookupErr AccountField f1 o
k2 <- lookupErr AccountField f2 o
lookupErr AccountField (k1, k2) m
evalCurrency :: TxRecord -> SplitCur -> T.Text
evalCurrency :: TxRecord -> SplitCur -> EitherErr T.Text
evalCurrency TxRecord {trOther = o} s = case s of
ConstT p -> p
LookupT f -> lookupField f o
MapT (Field f m) -> let k = lookupField f o in lookupErr "currency key" k m
Map2T (Field (f1, f2) m) ->
let k1 = lookupField f1 o
k2 = lookupField f2 o
in lookupErr "currency key" (k1, k2) m
ConstT p -> Right p
LookupT f -> lookupErr CurrencyField f o
MapT (Field f m) -> do
k <- lookupErr CurrencyField f o
lookupErr CurrencyField k m
Map2T (Field (f1, f2) m) -> do
k1 <- lookupErr CurrencyField f1 o
k2 <- lookupErr CurrencyField f2 o
lookupErr CurrencyField (k1, k2) m
errorT :: T.Text -> a
errorT = error . T.unpack
lookupField :: (Ord k, Show k) => k -> M.Map k v -> v
lookupField = lookupErr "field"
-- lookupField :: (Ord k, Show k) => k -> M.Map k v -> v
-- lookupField = lookupErr "field"
lookupErr :: (Ord k, Show k) => T.Text -> k -> M.Map k v -> v
lookupErr :: (Ord k, Show k) => LookupField -> k -> M.Map k v -> EitherErr v
lookupErr what k m = case M.lookup k m of
Just x -> x
_ -> errorT $ T.concat [what, " does not exist: ", T.pack $ show k]
Just x -> Right x
_ -> Left $ LookupError what $ showT k
matches :: Match -> TxRecord -> EitherErr (MatchRes RawTx)
matches Match {..} r@TxRecord {..} = do
let date = checkMaybe (`dateMatches` trDate) mDate
date <- maybe (Right True) (`dateMatches` trDate) mDate
let val = valMatches mVal trAmount
other <- foldM (\a o -> (a &&) <$> fieldMatches trOther o) True mOther
desc <- maybe (return True) (matchMaybe trDesc) mDesc
return $
if date && val && desc && other
then maybe MatchSkip (MatchPass . eval) mTx
else MatchFail
if date && val && desc && other
then maybe (Right MatchSkip) (fmap MatchPass . eval) mTx
else Right MatchFail
where
eval (ToTx cur a ss) = toTx cur a ss r
@ -137,32 +144,35 @@ matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re
fieldMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr Bool
fieldMatches dict m = case m of
Val (Field n mv) -> valMatches mv <$> (readRationalMsg =<< lookup_ n)
Val (Field n mv) -> valMatches mv <$> (readRational =<< lookup_ n)
Desc (Field n md) -> (`matchMaybe` md) =<< lookup_ n
where
lookup_ n = case M.lookup n dict of
Just r -> Right r
Nothing -> Left $ LookupError n
Nothing -> Left $ LookupError OtherField n
checkMaybe :: (a -> Bool) -> Maybe a -> Bool
checkMaybe = maybe True
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> RawTx
toTx sc sa toSplits r@TxRecord {..} =
Tx
{ txTags = []
, txDate = trDate
, txDescr = trDesc
, txSplits = fromSplit : fmap (evalSplit r) toSplits
}
where
fromSplit =
Split
{ sAcnt = evalAcnt r sa
, sCurrency = evalCurrency r sc
, sValue = Just trAmount
, sComment = ""
}
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErr RawTx
toTx sc sa toSplits r@TxRecord {..} = do
a_ <- evalAcnt r sa
c_ <- evalCurrency r sc
ss_ <- mapM (evalSplit r) toSplits
let fromSplit =
Split
{ sAcnt = a_
, sCurrency = c_
, sValue = Just trAmount
, sComment = ""
}
return $
Tx
{ txTags = []
, txDate = trDate
, txDescr = trDesc
, txSplits = fromSplit : ss_
}
parseRational :: MonadFail m => T.Text -> T.Text -> m Rational
parseRational pat s = case ms of
@ -197,34 +207,35 @@ parseRational pat s = case ms of
k <- readSign sign
return (k, w)
readRationalMsg :: T.Text -> EitherErr Rational
readRationalMsg t = maybe (Left $ ConversionError t) Right $ readRational t
-- readRationalMsg :: T.Text -> EitherErr Rational
-- readRationalMsg t = maybe (Left $ ConversionError t) Right $ readRational t
-- TODO don't use a partial function
readRational :: MonadFail m => T.Text -> m Rational
readRational s = case TP.splitOn "." s of
[x] -> return $ fromInteger $ readT x
[x, y] ->
let x' = readT x
y' = readT y
p = 10 ^ T.length y
k = if x' >= 0 then 1 else -1
in if y' > p
then fail "not enough precision to parse"
else return $ fromInteger x' + k * y' % p
_ -> fail $ T.unpack $ T.append "malformed decimal: " s
readRational :: T.Text -> EitherErr Rational
readRational s = case T.split (== '.') s of
[x] -> maybe err (return . fromInteger) $ readT x
[x, y] -> case (readT x, readT y) of
(Just x', Just y') ->
let p = 10 ^ T.length y
k = if x' >= 0 then 1 else -1
in return $ fromInteger x' + k * y' % p
_ -> err
_ -> err
where
readT = read . T.unpack
readT = readMaybe . T.unpack
err = Left $ ConversionError s
-- TODO smells like a lens
mapTxSplits :: (a -> b) -> Tx a -> Tx b
mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds
boundsFromGregorian = bimap fromGregorian' fromGregorian'
boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErr Bounds
boundsFromGregorian (a, b) = do
a_ <- fromGregorian' a
b_ <- fromGregorian' b
return (a_, b_)
fromGregorian' :: Gregorian -> Day
fromGregorian' = uncurry3 fromGregorian . gregTup
fromGregorian' :: Gregorian -> EitherErr Day
fromGregorian' = fmap (uncurry3 fromGregorian) . gregTup
inBounds :: Bounds -> Day -> Bool
inBounds (d0, d1) x = d0 <= x && x <= d1
@ -232,9 +243,11 @@ inBounds (d0, d1) x = d0 <= x && x <= d1
inMaybeBounds :: MaybeBounds -> Day -> Bool
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
intervalMaybeBounds :: Interval -> MaybeBounds
intervalMaybeBounds Interval {intStart = s, intEnd = e} =
(fromGregorian' <$> s, fromGregorian' <$> e)
intervalMaybeBounds :: Interval -> EitherErr MaybeBounds
intervalMaybeBounds Interval {intStart = s, intEnd = e} = do
s_ <- mapM fromGregorian' s
e_ <- mapM fromGregorian' e
return (s_, e_)
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
resolveBounds (s, e) = do
@ -264,11 +277,11 @@ lpad c n s = replicate (n - length s) c ++ s
rpad :: a -> Int -> [a] -> [a]
rpad c n s = s ++ replicate (n - length s) c
evalExp :: TxRecord -> SplitNum -> Maybe Rational
evalExp :: TxRecord -> SplitNum -> EitherErr Rational
evalExp r s = case s of
(LookupN t) -> readRational =<< M.lookup t (trOther r)
(ConstN c) -> Just $ dec2Rat c
AmountN -> Just $ trAmount r
(LookupN t) -> readRational =<< lookupErr OtherField t (trOther r)
(ConstN c) -> Right $ dec2Rat c
AmountN -> Right $ trAmount r
dec2Rat :: Decimal -> Rational
dec2Rat D {..} =
@ -282,10 +295,11 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
showError :: InsertError -> [T.Text]
showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms)
showError other = (: []) $ case other of
(YearError y) -> T.append "Year must be two digits: " $ showT y
(RegexError re) -> T.append "could not make regex from pattern: " re
(ConversionError x) -> T.append "Could not convert to rational number: " x
(LookupError f) -> T.append "Could not find field: " f
-- TODO these balance errors are useless, need more info on the tx being balanced
-- TODO use the field indicator
(LookupError _ f) -> T.append "Could not find field: " f
(BalanceError t cur rss) ->
T.concat
[ msg