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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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