module Hledger.Data.Dates (
getCurrentDay,
getCurrentMonth,
getCurrentYear,
nulldate,
spanContainsDate,
periodContainsDate,
parsedateM,
parsedate,
showDate,
showDateSpan,
elapsedSeconds,
prevday,
parsePeriodExpr,
nulldatespan,
failIfInvalidYear,
failIfInvalidMonth,
failIfInvalidDay,
datesepchar,
datesepchars,
spanStart,
spanEnd,
spansSpan,
spanIntersect,
spansIntersect,
spanDefaultsFrom,
spanUnion,
spansUnion,
smartdate,
splitSpan,
fixSmartDate,
fixSmartDateStr,
fixSmartDateStrEither,
fixSmartDateStrEither',
daysInSpan,
maybePeriod,
mkdatespan,
)
where
import Prelude ()
import Prelude.Compat
import Control.Monad
import Data.List.Compat
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format hiding (months)
#else
import Data.Time.Format
import System.Locale (TimeLocale, defaultTimeLocale)
#endif
import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate
import Data.Time.Clock
import Data.Time.LocalTime
import Safe (headMay, lastMay, readMay)
import Text.Megaparsec.Compat
import Text.Printf
import Hledger.Data.Types
import Hledger.Data.Period
import Hledger.Utils
instance Show DateSpan where
show s = "DateSpan " ++ showDateSpan s
showDate :: Day -> String
showDate = formatTime defaultTimeLocale "%0C%y/%m/%d"
showDateSpan :: DateSpan -> String
showDateSpan = showPeriod . dateSpanAsPeriod
getCurrentDay :: IO Day
getCurrentDay = do
t <- getZonedTime
return $ localDay (zonedTimeToLocalTime t)
getCurrentMonth :: IO Int
getCurrentMonth = do
(_,m,_) <- toGregorian `fmap` getCurrentDay
return m
getCurrentYear :: IO Integer
getCurrentYear = do
(y,_,_) <- toGregorian `fmap` getCurrentDay
return y
elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a
elapsedSeconds t1 = realToFrac . diffUTCTime t1
spanStart :: DateSpan -> Maybe Day
spanStart (DateSpan d _) = d
spanEnd :: DateSpan -> Maybe Day
spanEnd (DateSpan _ d) = d
spansSpan :: [DateSpan] -> DateSpan
spansSpan spans = DateSpan (maybe Nothing spanStart $ headMay spans) (maybe Nothing spanEnd $ lastMay spans)
splitSpan :: Interval -> DateSpan -> [DateSpan]
splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]
splitSpan NoInterval s = [s]
splitSpan (Days n) s = splitspan startofday (applyN n nextday) s
splitSpan (Weeks n) s = splitspan startofweek (applyN n nextweek) s
splitSpan (Months n) s = splitspan startofmonth (applyN n nextmonth) s
splitSpan (Quarters n) s = splitspan startofquarter (applyN n nextquarter) s
splitSpan (Years n) s = splitspan startofyear (applyN n nextyear) s
splitSpan (DayOfMonth n) s = splitspan (nthdayofmonthcontaining n) (applyN (n1) nextday . nextmonth) s
splitSpan (DayOfWeek n) s = splitspan (nthdayofweekcontaining n) (applyN (n1) nextday . nextweek) s
splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan _ _ (DateSpan Nothing Nothing) = []
splitspan start next (DateSpan Nothing (Just e)) = splitspan start next (DateSpan (Just $ start e) (Just $ next $ start e))
splitspan start next (DateSpan (Just s) Nothing) = splitspan start next (DateSpan (Just $ start s) (Just $ next $ start s))
splitspan start next span@(DateSpan (Just s) (Just e))
| s == e = [span]
| otherwise = splitspan' start next span
where
splitspan' start next (DateSpan (Just s) (Just e))
| s >= e = []
| otherwise = DateSpan (Just subs) (Just sube) : splitspan' start next (DateSpan (Just sube) (Just e))
where subs = start s
sube = next subs
splitspan' _ _ _ = error' "won't happen, avoids warnings"
daysInSpan :: DateSpan -> Maybe Integer
daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1
daysInSpan _ = Nothing
spanContainsDate :: DateSpan -> Day -> Bool
spanContainsDate (DateSpan Nothing Nothing) _ = True
spanContainsDate (DateSpan Nothing (Just e)) d = d < e
spanContainsDate (DateSpan (Just b) Nothing) d = d >= b
spanContainsDate (DateSpan (Just b) (Just e)) d = d >= b && d < e
periodContainsDate :: Period -> Day -> Bool
periodContainsDate p = spanContainsDate (periodAsDateSpan p)
spansIntersect [] = nulldatespan
spansIntersect [d] = d
spansIntersect (d:ds) = d `spanIntersect` (spansIntersect ds)
spanIntersect (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e
where
b = latest b1 b2
e = earliest e1 e2
spanDefaultsFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b
where a = if isJust a1 then a1 else a2
b = if isJust b1 then b1 else b2
spansUnion [] = nulldatespan
spansUnion [d] = d
spansUnion (d:ds) = d `spanUnion` (spansUnion ds)
spanUnion (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e
where
b = earliest b1 b2
e = latest e1 e2
latest d Nothing = d
latest Nothing d = d
latest (Just d1) (Just d2) = Just $ max d1 d2
earliest d Nothing = d
earliest Nothing d = d
earliest (Just d1) (Just d2) = Just $ min d1 d2
parsePeriodExpr :: Day -> Text -> Either (ParseError Char MPErr) (Interval, DateSpan)
parsePeriodExpr refdate = parsewith (periodexpr refdate <* eof)
maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)
maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate
spanFromSmartDate :: Day -> SmartDate -> DateSpan
spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)
where
(ry,rm,_) = toGregorian refdate
(b,e) = span sdate
span :: SmartDate -> (Day,Day)
span ("","","today") = (refdate, nextday refdate)
span ("","this","day") = (refdate, nextday refdate)
span ("","","yesterday") = (prevday refdate, refdate)
span ("","last","day") = (prevday refdate, refdate)
span ("","","tomorrow") = (nextday refdate, addDays 2 refdate)
span ("","next","day") = (nextday refdate, addDays 2 refdate)
span ("","last","week") = (prevweek refdate, thisweek refdate)
span ("","this","week") = (thisweek refdate, nextweek refdate)
span ("","next","week") = (nextweek refdate, startofweek $ addDays 14 refdate)
span ("","last","month") = (prevmonth refdate, thismonth refdate)
span ("","this","month") = (thismonth refdate, nextmonth refdate)
span ("","next","month") = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate)
span ("","last","quarter") = (prevquarter refdate, thisquarter refdate)
span ("","this","quarter") = (thisquarter refdate, nextquarter refdate)
span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate)
span ("","last","year") = (prevyear refdate, thisyear refdate)
span ("","this","year") = (thisyear refdate, nextyear refdate)
span ("","next","year") = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate)
span ("","",d) = (day, nextday day) where day = fromGregorian ry rm (read d)
span ("",m,"") = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1
span ("",m,d) = (day, nextday day) where day = fromGregorian ry (read m) (read d)
span (y,"","") = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1
span (y,m,"") = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1
span (y,m,d) = (day, nextday day) where day = fromGregorian (read y) (read m) (read d)
fixSmartDateStr :: Day -> Text -> String
fixSmartDateStr d s = either
(\e->error' $ printf "could not parse date %s %s" (show s) (show e))
id
$ (fixSmartDateStrEither d s :: Either (ParseError Char MPErr) String)
fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char MPErr) String
fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d
fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char MPErr) Day
fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of
Right sd -> Right $ fixSmartDate d sd
Left e -> Left e
fixSmartDate :: Day -> SmartDate -> Day
fixSmartDate refdate sdate = fix sdate
where
fix :: SmartDate -> Day
fix ("","","today") = fromGregorian ry rm rd
fix ("","this","day") = fromGregorian ry rm rd
fix ("","","yesterday") = prevday refdate
fix ("","last","day") = prevday refdate
fix ("","","tomorrow") = nextday refdate
fix ("","next","day") = nextday refdate
fix ("","last","week") = prevweek refdate
fix ("","this","week") = thisweek refdate
fix ("","next","week") = nextweek refdate
fix ("","last","month") = prevmonth refdate
fix ("","this","month") = thismonth refdate
fix ("","next","month") = nextmonth refdate
fix ("","last","quarter") = prevquarter refdate
fix ("","this","quarter") = thisquarter refdate
fix ("","next","quarter") = nextquarter refdate
fix ("","last","year") = prevyear refdate
fix ("","this","year") = thisyear refdate
fix ("","next","year") = nextyear refdate
fix ("","",d) = fromGregorian ry rm (read d)
fix ("",m,"") = fromGregorian ry (read m) 1
fix ("",m,d) = fromGregorian ry (read m) (read d)
fix (y,"","") = fromGregorian (read y) 1 1
fix (y,m,"") = fromGregorian (read y) (read m) 1
fix (y,m,d) = fromGregorian (read y) (read m) (read d)
(ry,rm,rd) = toGregorian refdate
prevday :: Day -> Day
prevday = addDays (1)
nextday = addDays 1
startofday = id
thisweek = startofweek
prevweek = startofweek . addDays (7)
nextweek = startofweek . addDays 7
startofweek day = fromMondayStartWeek y w 1
where
(y,_,_) = toGregorian day
(w,_) = mondayStartWeek day
thismonth = startofmonth
prevmonth = startofmonth . addGregorianMonthsClip (1)
nextmonth = startofmonth . addGregorianMonthsClip 1
startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day
thisquarter = startofquarter
prevquarter = startofquarter . addGregorianMonthsClip (3)
nextquarter = startofquarter . addGregorianMonthsClip 3
startofquarter day = fromGregorian y (firstmonthofquarter m) 1
where
(y,m,_) = toGregorian day
firstmonthofquarter m = ((m1) `div` 3) * 3 + 1
thisyear = startofyear
prevyear = startofyear . addGregorianYearsClip (1)
nextyear = startofyear . addGregorianYearsClip 1
startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day
nthdayofmonthcontaining n d | d1 >= d = d1
| otherwise = d2
where d1 = addDays (fromIntegral n1) s
d2 = addDays (fromIntegral n1) $ nextmonth s
s = startofmonth d
nthdayofweekcontaining n d | d1 >= d = d1
| otherwise = d2
where d1 = addDays (fromIntegral n1) s
d2 = addDays (fromIntegral n1) $ nextweek s
s = startofweek d
parsetime :: ParseTime t => TimeLocale -> String -> String -> Maybe t
parsetime =
#if MIN_VERSION_time(1,5,0)
parseTimeM True
#else
parseTime
#endif
parsedateM :: String -> Maybe Day
parsedateM s = firstJust [
parsetime defaultTimeLocale "%Y/%m/%d" s,
parsetime defaultTimeLocale "%Y-%m-%d" s
]
parsedate :: String -> Day
parsedate s = fromMaybe (error' $ "could not parse date \"" ++ s ++ "\"")
(parsedateM s)
_parsetimewith :: ParseTime t => String -> String -> t -> t
_parsetimewith pat s def = fromMaybe def $ parsetime defaultTimeLocale pat s
smartdate :: SimpleTextParser SmartDate
smartdate = do
(y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing]
return (y,m,d)
smartdateonly :: SimpleTextParser SmartDate
smartdateonly = do
d <- smartdate
many spacenonewline
eof
return d
datesepchars :: [Char]
datesepchars = "/-."
datesepchar :: TextParser m Char
datesepchar = oneOf datesepchars
validYear, validMonth, validDay :: String -> Bool
validYear s = length s >= 4 && isJust (readMay s :: Maybe Year)
validMonth s = maybe False (\n -> n>=1 && n<=12) $ readMay s
validDay s = maybe False (\n -> n>=1 && n<=31) $ readMay s
failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: (Monad m) => String -> m ()
failIfInvalidYear s = unless (validYear s) $ fail $ "bad year number: " ++ s
failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s
failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s
yyyymmdd :: SimpleTextParser SmartDate
yyyymmdd = do
y <- count 4 digitChar
m <- count 2 digitChar
failIfInvalidMonth m
d <- count 2 digitChar
failIfInvalidDay d
return (y,m,d)
ymd :: SimpleTextParser SmartDate
ymd = do
y <- some digitChar
failIfInvalidYear y
sep <- datesepchar
m <- some digitChar
failIfInvalidMonth m
char sep
d <- some digitChar
failIfInvalidDay d
return $ (y,m,d)
ym :: SimpleTextParser SmartDate
ym = do
y <- some digitChar
failIfInvalidYear y
datesepchar
m <- some digitChar
failIfInvalidMonth m
return (y,m,"")
y :: SimpleTextParser SmartDate
y = do
y <- some digitChar
failIfInvalidYear y
return (y,"","")
d :: SimpleTextParser SmartDate
d = do
d <- some digitChar
failIfInvalidDay d
return ("","",d)
md :: SimpleTextParser SmartDate
md = do
m <- some digitChar
failIfInvalidMonth m
datesepchar
d <- some digitChar
failIfInvalidDay d
return ("",m,d)
months = ["january","february","march","april","may","june",
"july","august","september","october","november","december"]
monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]
#if MIN_VERSION_megaparsec(6,0,0)
lc = T.toLower
#else
lc = lowercase
#endif
monthIndex t = maybe 0 (+1) $ lc t `elemIndex` months
monIndex t = maybe 0 (+1) $ lc t `elemIndex` monthabbrevs
month :: SimpleTextParser SmartDate
month = do
m <- choice $ map (try . string) months
let i = monthIndex m
return ("",show i,"")
mon :: SimpleTextParser SmartDate
mon = do
m <- choice $ map (try . string) monthabbrevs
let i = monIndex m
return ("",show i,"")
today,yesterday,tomorrow :: SimpleTextParser SmartDate
today = string "today" >> return ("","","today")
yesterday = string "yesterday" >> return ("","","yesterday")
tomorrow = string "tomorrow" >> return ("","","tomorrow")
lastthisnextthing :: SimpleTextParser SmartDate
lastthisnextthing = do
r <- choice $ map mptext [
"last"
,"this"
,"next"
]
many spacenonewline
p <- choice $ map mptext [
"day"
,"week"
,"month"
,"quarter"
,"year"
]
return ("", T.unpack r, T.unpack p)
periodexpr :: Day -> SimpleTextParser (Interval, DateSpan)
periodexpr rdate = choice $ map try [
intervalanddateperiodexpr rdate,
intervalperiodexpr,
dateperiodexpr rdate,
(return (NoInterval,DateSpan Nothing Nothing))
]
intervalanddateperiodexpr :: Day -> SimpleTextParser (Interval, DateSpan)
intervalanddateperiodexpr rdate = do
many spacenonewline
i <- reportinginterval
many spacenonewline
s <- periodexprdatespan rdate
return (i,s)
intervalperiodexpr :: SimpleTextParser (Interval, DateSpan)
intervalperiodexpr = do
many spacenonewline
i <- reportinginterval
return (i, DateSpan Nothing Nothing)
dateperiodexpr :: Day -> SimpleTextParser (Interval, DateSpan)
dateperiodexpr rdate = do
many spacenonewline
s <- periodexprdatespan rdate
return (NoInterval, s)
reportinginterval :: SimpleTextParser Interval
reportinginterval = choice' [
tryinterval "day" "daily" Days,
tryinterval "week" "weekly" Weeks,
tryinterval "month" "monthly" Months,
tryinterval "quarter" "quarterly" Quarters,
tryinterval "year" "yearly" Years,
do string "biweekly"
return $ Weeks 2,
do string "bimonthly"
return $ Months 2,
do string "every"
many spacenonewline
n <- fmap read $ some digitChar
thsuffix
many spacenonewline
string "day"
many spacenonewline
string "of"
many spacenonewline
string "week"
return $ DayOfWeek n,
do string "every"
many spacenonewline
n <- fmap read $ some digitChar
thsuffix
many spacenonewline
string "day"
optional $ do
many spacenonewline
string "of"
many spacenonewline
string "month"
return $ DayOfMonth n
]
where
thsuffix = choice' $ map string ["st","nd","rd","th"]
tryinterval :: String -> String -> (Int -> Interval) -> SimpleTextParser Interval
tryinterval singular compact intcons =
choice' [
do mptext compact'
return $ intcons 1,
do mptext "every"
many spacenonewline
mptext singular'
return $ intcons 1,
do mptext "every"
many spacenonewline
n <- fmap read $ some digitChar
many spacenonewline
mptext plural'
return $ intcons n
]
where
compact' = T.pack compact
singular' = T.pack singular
plural' = T.pack $ singular ++ "s"
periodexprdatespan :: Day -> SimpleTextParser DateSpan
periodexprdatespan rdate = choice $ map try [
doubledatespan rdate,
fromdatespan rdate,
todatespan rdate,
justdatespan rdate
]
doubledatespan :: Day -> SimpleTextParser DateSpan
doubledatespan rdate = do
optional (string "from" >> many spacenonewline)
b <- smartdate
many spacenonewline
optional (choice [string "to", string "-"] >> many spacenonewline)
e <- smartdate
return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)
fromdatespan :: Day -> SimpleTextParser DateSpan
fromdatespan rdate = do
b <- choice [
do
string "from" >> many spacenonewline
smartdate
,
do
d <- smartdate
string "-"
return d
]
return $ DateSpan (Just $ fixSmartDate rdate b) Nothing
todatespan :: Day -> SimpleTextParser DateSpan
todatespan rdate = do
choice [string "to", string "-"] >> many spacenonewline
e <- smartdate
return $ DateSpan Nothing (Just $ fixSmartDate rdate e)
justdatespan :: Day -> SimpleTextParser DateSpan
justdatespan rdate = do
optional (string "in" >> many spacenonewline)
d <- smartdate
return $ spanFromSmartDate rdate d
mkdatespan :: String -> String -> DateSpan
mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate
nulldatespan :: DateSpan
nulldatespan = DateSpan Nothing Nothing
nulldate :: Day
nulldate = fromGregorian 0 1 1