WIP use pure errors everywhere
This commit is contained in:
parent
0d0c961f1a
commit
fc6cde2716
15
app/Main.hs
15
app/Main.hs
|
@ -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
|
||||||
|
|
|
@ -302,8 +302,17 @@ 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
|
||||||
|
=> 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
|
am <- updateAccounts $ accounts c
|
||||||
cm <- updateCurrencies $ currencies c
|
cm <- updateCurrencies $ currencies c
|
||||||
hs <- updateHashes c
|
hs <- updateHashes c
|
||||||
|
@ -313,8 +322,8 @@ getDBState c = do
|
||||||
DBState
|
DBState
|
||||||
{ kmCurrency = cm
|
{ kmCurrency = cm
|
||||||
, kmAccount = am
|
, kmAccount = am
|
||||||
, kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c
|
, kmBudgetInterval = budgetInt
|
||||||
, kmStatementInterval = intervalMaybeBounds $ statementInterval $ global c
|
, kmStatementInterval = statementInt
|
||||||
, kmNewCommits = hs
|
, kmNewCommits = hs
|
||||||
, kmConfigDir = f
|
, kmConfigDir = f
|
||||||
}
|
}
|
||||||
|
|
|
@ -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
|
|
||||||
}
|
|
||||||
(lower, upper) =
|
|
||||||
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,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
|
||||||
|
Left e -> return $ Just e
|
||||||
|
Right days -> do
|
||||||
|
forM_ days $ \day -> do
|
||||||
alloTx <- concat <$> mapM (allocationToTx from day) as
|
alloTx <- concat <$> mapM (allocationToTx from day) as
|
||||||
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 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
|
||||||
|
Left err -> return $ Just err
|
||||||
|
Right days -> do
|
||||||
|
ts <- mapM tx days
|
||||||
lift $ mapM_ (insertTx c) ts
|
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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
res <- f a x
|
||||||
|
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 -> Left z
|
LT -> return $ Left z
|
||||||
goEq z@(Unzipped _ _ []) = z
|
goEq z@(Unzipped _ _ []) = return z
|
||||||
goEq z@(Unzipped bs cs (a : as)) = case f a x of
|
goEq z@(Unzipped bs cs (a : as)) = do
|
||||||
|
res <- f a x
|
||||||
|
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 -> z
|
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,7 +172,9 @@ 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
|
||||||
|
sliced <- zipperSlice findDate r z
|
||||||
|
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
|
||||||
|
@ -177,7 +183,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 EQ (`compareDate` trDate r) $ mDate m
|
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)
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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,41 +19,47 @@ 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 =
|
||||||
|
return
|
||||||
( fromIntegral gYear + 2000
|
( fromIntegral gYear + 2000
|
||||||
, fromIntegral gMonth
|
, fromIntegral gMonth
|
||||||
, fromIntegral gDay
|
, 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 =
|
||||||
|
return
|
||||||
( fromIntegral gmYear + 2000
|
( fromIntegral gmYear + 2000
|
||||||
, fromIntegral gmMonth
|
, 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
|
||||||
|
res <- fromMatchYMD md
|
||||||
|
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 = case fromMatchYMD md of
|
compareDate (In md offset) x = do
|
||||||
|
res <- fromMatchYMD md
|
||||||
|
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' ->
|
||||||
|
@ -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 MatchSkip (MatchPass . eval) mTx
|
then maybe (Right MatchSkip) (fmap MatchPass . eval) mTx
|
||||||
else MatchFail
|
else Right MatchFail
|
||||||
where
|
where
|
||||||
eval (ToTx cur a ss) = toTx cur a ss r
|
eval (ToTx cur a ss) = toTx cur a ss r
|
||||||
|
|
||||||
|
@ -137,31 +144,34 @@ 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
|
||||||
|
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
|
Tx
|
||||||
{ txTags = []
|
{ txTags = []
|
||||||
, txDate = trDate
|
, txDate = trDate
|
||||||
, txDescr = trDesc
|
, txDescr = trDesc
|
||||||
, txSplits = fromSplit : fmap (evalSplit r) toSplits
|
, txSplits = fromSplit : ss_
|
||||||
}
|
|
||||||
where
|
|
||||||
fromSplit =
|
|
||||||
Split
|
|
||||||
{ sAcnt = evalAcnt r sa
|
|
||||||
, sCurrency = evalCurrency r sc
|
|
||||||
, sValue = Just trAmount
|
|
||||||
, sComment = ""
|
|
||||||
}
|
}
|
||||||
|
|
||||||
parseRational :: MonadFail m => T.Text -> T.Text -> m Rational
|
parseRational :: MonadFail m => T.Text -> T.Text -> m Rational
|
||||||
|
@ -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
|
|
||||||
p = 10 ^ T.length y
|
|
||||||
k = if x' >= 0 then 1 else -1
|
k = if x' >= 0 then 1 else -1
|
||||||
in if y' > p
|
in return $ fromInteger x' + k * y' % p
|
||||||
then fail "not enough precision to parse"
|
_ -> err
|
||||||
else return $ fromInteger x' + k * y' % p
|
_ -> err
|
||||||
_ -> 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
|
||||||
|
|
Loading…
Reference in New Issue