ENH use normal years in dates

This commit is contained in:
Nathan Dwarshuis 2023-01-28 19:32:56 -05:00
parent b2e6047800
commit f9c1e36ee8
6 changed files with 163 additions and 193 deletions

View File

@ -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

View File

@ -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
} }

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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