2020-10-07 05:45:46 +03:00
{- # LANGUAGE FlexibleContexts # -}
{- # LANGUAGE NoMonoLocalBinds # -}
{- # LANGUAGE OverloadedStrings # -}
2017-07-27 14:59:55 +03:00
{- # LANGUAGE ScopedTypeVariables # -}
2020-10-07 05:45:46 +03:00
{- # LANGUAGE TypeFamilies # -}
2008-11-11 15:34:05 +03:00
{- |
2009-12-13 01:19:57 +03:00
Date parsing and utilities for hledger .
2008-11-27 07:31:01 +03:00
For date and time values , we use the standard Day and UTCTime types .
2008-11-27 03:35:00 +03:00
A 'SmartDate' is a date which may be partially - specified or relative .
2021-12-20 16:36:33 +03:00
Eg 2008 \/ 12 \/ 31 , but also 2008 \/ 12 , 12 \/ 31 , tomorrow , last week , next year ,
in 5 days , in - 3 quarters .
2008-11-27 10:50:02 +03:00
We represent these as a triple of strings like ( \ " 2008 \ " , \ " 12 \ " , \ " \ " ),
( \ " \ " , \ " \ " , \ " tomorrow \ " ), ( \ " \ " , \ " last \ " , \ " week \ " ).
2008-11-11 15:34:05 +03:00
2008-11-27 07:31:01 +03:00
A 'DateSpan' is the span of time between two specific calendar dates , or
2008-12-04 02:20:38 +03:00
an open - ended span where one or both dates are unspecified . ( A date span
with both ends unspecified matches all dates . )
2010-08-03 21:05:02 +04:00
An 'Interval' is ledger's \ " reporting interval \ " - weekly, monthly,
2008-12-04 02:20:38 +03:00
quarterly , etc .
2008-11-27 07:31:01 +03:00
2016-07-29 21:00:29 +03:00
'Period' will probably replace DateSpan in due course .
2008-11-11 15:34:05 +03:00
- }
2011-04-22 17:55:42 +04:00
-- XXX fromGregorian silently clips bad dates, use fromGregorianValid instead ?
2012-04-16 20:44:41 +04:00
module Hledger.Data.Dates (
-- * Misc date handling utilities
2023-01-19 12:02:09 +03:00
fromEFDay ,
modifyEFDay ,
2012-04-16 20:44:41 +04:00
getCurrentDay ,
getCurrentMonth ,
getCurrentYear ,
nulldate ,
spanContainsDate ,
2016-12-03 02:36:23 +03:00
periodContainsDate ,
2012-12-06 04:28:23 +04:00
parsedateM ,
2012-04-16 20:44:41 +04:00
showDate ,
2023-01-19 12:02:09 +03:00
showEFDate ,
2013-09-27 02:06:48 +04:00
showDateSpan ,
2023-01-19 12:02:09 +03:00
showDateSpanDebug ,
2024-06-14 11:16:10 +03:00
showDateSpanAbbrev ,
2012-04-16 20:44:41 +04:00
elapsedSeconds ,
prevday ,
2018-06-12 22:29:22 +03:00
periodexprp ,
2012-04-16 20:44:41 +04:00
parsePeriodExpr ,
2018-06-09 05:35:27 +03:00
parsePeriodExpr' ,
2012-04-16 20:44:41 +04:00
nulldatespan ,
2018-10-17 23:10:49 +03:00
emptydatespan ,
2012-04-16 20:44:41 +04:00
datesepchar ,
datesepchars ,
2018-05-22 04:52:34 +03:00
isDateSepChar ,
2013-12-07 02:06:12 +04:00
spanStart ,
spanEnd ,
2020-07-09 22:52:40 +03:00
spanStartYear ,
spanEndYear ,
spanYears ,
2013-12-07 02:06:12 +04:00
spansSpan ,
2012-04-16 20:44:41 +04:00
spanIntersect ,
2012-05-19 06:56:26 +04:00
spansIntersect ,
2014-04-19 19:38:03 +04:00
spanDefaultsFrom ,
2024-03-02 07:07:13 +03:00
spanExtend ,
2012-05-19 06:56:26 +04:00
spanUnion ,
spansUnion ,
2019-11-12 04:14:21 +03:00
daysSpan ,
latestSpanContaining ,
2012-04-16 20:44:41 +04:00
smartdate ,
splitSpan ,
2022-01-04 17:38:21 +03:00
spansFromBoundaries ,
2021-09-17 09:15:32 +03:00
groupByDateSpan ,
2012-04-16 20:44:41 +04:00
fixSmartDate ,
fixSmartDateStr ,
2012-04-16 21:09:27 +04:00
fixSmartDateStrEither ,
2012-04-16 20:44:41 +04:00
fixSmartDateStrEither' ,
2020-07-28 16:00:25 +03:00
yearp ,
2012-04-16 20:44:41 +04:00
daysInSpan ,
2021-07-31 00:28:30 +03:00
tests_Dates
2023-01-11 20:32:59 +03:00
, intervalBoundaryBefore )
2008-11-22 15:18:19 +03:00
where
2008-11-11 15:34:05 +03:00
2023-03-14 23:39:28 +03:00
import Prelude hiding ( Applicative ( .. ) )
import Control.Applicative ( Applicative ( .. ) )
2018-09-30 04:32:08 +03:00
import Control.Applicative.Permutations
2019-11-12 04:14:21 +03:00
import Control.Monad ( guard , unless )
2023-03-14 23:39:28 +03:00
import qualified Control.Monad.Fail as Fail ( MonadFail , fail )
2020-08-03 09:01:12 +03:00
import Data.Char ( digitToInt , isDigit , ord )
2021-09-17 09:15:32 +03:00
import Data.Default ( def )
2020-02-28 10:31:53 +03:00
import Data.Foldable ( asum )
2020-07-21 05:42:28 +03:00
import Data.Function ( on )
2021-08-16 07:57:15 +03:00
import Data.Functor ( ( $> ) )
2021-09-27 15:03:29 +03:00
import Data.List ( elemIndex , group , sort , sortBy )
2021-09-17 09:15:32 +03:00
import Data.Maybe ( catMaybes , fromMaybe , isJust , mapMaybe )
import Data.Ord ( comparing )
2019-11-12 04:14:21 +03:00
import qualified Data.Set as Set
2016-07-29 18:57:10 +03:00
import Data.Text ( Text )
import qualified Data.Text as T
2015-03-28 01:42:32 +03:00
import Data.Time.Format hiding ( months )
2011-05-28 08:11:44 +04:00
import Data.Time.Calendar
2021-09-17 09:15:32 +03:00
( Day , addDays , addGregorianYearsClip , addGregorianMonthsClip , diffDays ,
fromGregorian , fromGregorianValid , toGregorian )
import Data.Time.Calendar.OrdinalDate ( fromMondayStartWeek , mondayStartWeek )
import Data.Time.Clock ( UTCTime , diffUTCTime )
import Data.Time.LocalTime ( getZonedTime , localDay , zonedTimeToLocalTime )
2024-02-29 04:36:20 +03:00
import Safe ( headErr , headMay , lastMay , maximumMay , minimumMay )
2018-05-22 01:47:56 +03:00
import Text.Megaparsec
2021-09-17 09:15:32 +03:00
import Text.Megaparsec.Char ( char , char' , digitChar , string , string' )
2021-12-20 16:36:33 +03:00
import Text.Megaparsec.Char.Lexer ( decimal , signed )
2021-09-17 09:15:32 +03:00
import Text.Printf ( printf )
2011-05-28 08:11:44 +04:00
2010-05-20 03:08:53 +04:00
import Hledger.Data.Types
2016-07-29 21:00:29 +03:00
import Hledger.Data.Period
2011-05-28 08:11:44 +04:00
import Hledger.Utils
2008-11-11 15:34:05 +03:00
2014-04-04 02:19:45 +04:00
-- Help ppShow parse and line-wrap DateSpans better in debug output.
instance Show DateSpan where
2020-11-05 04:58:04 +03:00
show s = " DateSpan " ++ T . unpack ( showDateSpan s )
2014-04-04 02:19:45 +04:00
2020-11-05 04:58:04 +03:00
showDate :: Day -> Text
showDate = T . pack . show
2008-11-11 15:34:05 +03:00
2023-01-19 12:02:09 +03:00
showEFDate :: EFDay -> Text
showEFDate = showDate . fromEFDay
2014-07-27 03:54:18 +04:00
-- | Render a datespan as a display string, abbreviating into a
-- compact form if possible.
2023-01-19 12:02:09 +03:00
-- Warning, hides whether dates are Exact or Flex.
2020-11-05 04:58:04 +03:00
showDateSpan :: DateSpan -> Text
2016-07-29 21:00:29 +03:00
showDateSpan = showPeriod . dateSpanAsPeriod
2013-09-27 02:06:48 +04:00
2023-01-19 12:02:09 +03:00
-- | Show a DateSpan with its begin/end dates, exact or flex.
showDateSpanDebug :: DateSpan -> String
showDateSpanDebug ( DateSpan b e ) = " DateSpan ( " <> show b <> " ) ( " <> show e <> " ) "
2018-01-18 22:46:12 +03:00
-- | Like showDateSpan, but show month spans as just the abbreviated month name
-- in the current locale.
2024-06-14 11:16:10 +03:00
showDateSpanAbbrev :: DateSpan -> Text
showDateSpanAbbrev = showPeriodAbbrev . dateSpanAsPeriod
2018-01-18 22:46:12 +03:00
2011-03-11 21:45:57 +03:00
-- | Get the current local date.
2009-01-24 22:48:37 +03:00
getCurrentDay :: IO Day
2019-02-14 16:14:52 +03:00
getCurrentDay = localDay . zonedTimeToLocalTime <$> getZonedTime
2008-11-27 03:35:00 +03:00
2011-08-07 19:31:36 +04:00
-- | Get the current local month number.
getCurrentMonth :: IO Int
2019-02-14 16:14:52 +03:00
getCurrentMonth = second3 . toGregorian <$> getCurrentDay
2011-08-07 19:31:36 +04:00
2011-03-11 21:45:57 +03:00
-- | Get the current local year.
getCurrentYear :: IO Integer
2019-02-14 16:14:52 +03:00
getCurrentYear = first3 . toGregorian <$> getCurrentDay
2011-03-11 21:45:57 +03:00
2008-11-27 07:01:07 +03:00
elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a
2009-09-22 19:56:59 +04:00
elapsedSeconds t1 = realToFrac . diffUTCTime t1
2008-11-27 03:35:00 +03:00
2013-12-07 02:06:12 +04:00
spanStart :: DateSpan -> Maybe Day
2023-01-19 12:02:09 +03:00
spanStart ( DateSpan d _ ) = fromEFDay <$> d
2013-12-07 02:06:12 +04:00
spanEnd :: DateSpan -> Maybe Day
2023-01-19 12:02:09 +03:00
spanEnd ( DateSpan _ d ) = fromEFDay <$> d
spanStartDate :: DateSpan -> Maybe EFDay
spanStartDate ( DateSpan d _ ) = d
spanEndDate :: DateSpan -> Maybe EFDay
spanEndDate ( DateSpan _ d ) = d
2013-12-07 02:06:12 +04:00
2020-07-09 22:52:40 +03:00
spanStartYear :: DateSpan -> Maybe Year
2023-01-19 12:02:09 +03:00
spanStartYear ( DateSpan d _ ) = fmap ( first3 . toGregorian . fromEFDay ) d
2020-07-09 22:52:40 +03:00
spanEndYear :: DateSpan -> Maybe Year
2023-01-19 12:02:09 +03:00
spanEndYear ( DateSpan d _ ) = fmap ( first3 . toGregorian . fromEFDay ) d
2020-07-09 22:52:40 +03:00
-- | Get the 0-2 years mentioned explicitly in a DateSpan.
spanYears :: DateSpan -> [ Year ]
2023-01-19 12:02:09 +03:00
spanYears ( DateSpan ma mb ) = mapMaybe ( fmap ( first3 . toGregorian . fromEFDay ) ) [ ma , mb ]
2020-07-09 22:52:40 +03:00
2014-09-11 00:07:53 +04:00
-- might be useful later: http://en.wikipedia.org/wiki/Allen%27s_interval_algebra
2014-04-19 22:45:47 +04:00
2013-12-07 02:06:12 +04:00
-- | Get overall span enclosing multiple sequentially ordered spans.
2023-01-19 12:02:09 +03:00
-- The start and end date will be exact or flexible depending on
-- the first span's start date and last span's end date.
2013-12-07 02:06:12 +04:00
spansSpan :: [ DateSpan ] -> DateSpan
2023-01-19 12:02:09 +03:00
spansSpan spans = DateSpan ( spanStartDate =<< headMay spans ) ( spanEndDate =<< lastMay spans )
2013-12-07 02:06:12 +04:00
2023-01-19 12:02:09 +03:00
-- | Split a DateSpan into consecutive exact spans of the specified Interval.
2014-04-14 19:31:34 +04:00
-- If no interval is specified, the original span is returned.
2018-03-29 20:09:15 +03:00
-- If the original span is the null date span, ie unbounded, the null date span is returned.
-- If the original span is empty, eg if the end date is <= the start date, no spans are returned.
2019-07-15 13:28:52 +03:00
--
2024-09-04 16:59:14 +03:00
-- ==== Date adjustment
-- Some intervals respect the "adjust" flag (years, quarters, months, weeks, every Nth weekday
-- of month seem to be the ones that need it). This will move the start date earlier, if needed,
-- to the previous natural interval boundary (first of year, first of quarter, first of month,
-- monday, previous Nth weekday of month). Related: #1982 #2218
--
-- The end date is always moved later if needed to the next natural interval boundary,
-- so that the last period is the same length as the others.
--
-- ==== Examples
2023-01-19 12:02:09 +03:00
-- >>> let t i y1 m1 d1 y2 m2 d2 = splitSpan True i $ DateSpan (Just $ Flex $ fromGregorian y1 m1 d1) (Just $ Flex $ fromGregorian y2 m2 d2)
2020-08-26 11:11:20 +03:00
-- >>> t NoInterval 2008 01 01 2009 01 01
2016-05-07 04:05:42 +03:00
-- [DateSpan 2008]
2020-08-26 11:11:20 +03:00
-- >>> t (Quarters 1) 2008 01 01 2009 01 01
2020-03-22 15:51:18 +03:00
-- [DateSpan 2008Q1,DateSpan 2008Q2,DateSpan 2008Q3,DateSpan 2008Q4]
2023-01-13 05:19:52 +03:00
-- >>> splitSpan True (Quarters 1) nulldatespan
2020-03-22 15:51:18 +03:00
-- [DateSpan ..]
2020-08-26 11:11:20 +03:00
-- >>> t (Days 1) 2008 01 01 2008 01 01 -- an empty datespan
2018-03-29 20:09:15 +03:00
-- []
2020-08-26 11:11:20 +03:00
-- >>> t (Quarters 1) 2008 01 01 2008 01 01
2018-03-29 20:09:15 +03:00
-- []
2020-08-26 11:11:20 +03:00
-- >>> t (Months 1) 2008 01 01 2008 04 01
2020-03-22 15:51:18 +03:00
-- [DateSpan 2008-01,DateSpan 2008-02,DateSpan 2008-03]
2020-08-26 11:11:20 +03:00
-- >>> t (Months 2) 2008 01 01 2008 04 01
2020-03-22 15:51:18 +03:00
-- [DateSpan 2008-01-01..2008-02-29,DateSpan 2008-03-01..2008-04-30]
2020-08-26 11:11:20 +03:00
-- >>> t (Weeks 1) 2008 01 01 2008 01 15
2024-06-25 20:36:43 +03:00
-- [DateSpan 2007-W01,DateSpan 2008-W02,DateSpan 2008-W03]
2020-08-26 11:11:20 +03:00
-- >>> t (Weeks 2) 2008 01 01 2008 01 15
2020-03-22 15:51:18 +03:00
-- [DateSpan 2007-12-31..2008-01-13,DateSpan 2008-01-14..2008-01-27]
2024-09-04 17:28:27 +03:00
-- >>> t (MonthDay 2) 2008 01 01 2008 04 01
2024-08-30 01:07:24 +03:00
-- [DateSpan 2008-01-02..2008-02-01,DateSpan 2008-02-02..2008-03-01,DateSpan 2008-03-02..2008-04-01]
2024-09-04 17:28:27 +03:00
-- >>> t (NthWeekdayOfMonth 2 4) 2011 01 01 2011 02 15
2020-03-22 15:51:18 +03:00
-- [DateSpan 2010-12-09..2011-01-12,DateSpan 2011-01-13..2011-02-09,DateSpan 2011-02-10..2011-03-09]
2021-07-31 00:28:30 +03:00
-- >>> t (DaysOfWeek [2]) 2011 01 01 2011 01 15
2020-03-22 15:51:18 +03:00
-- [DateSpan 2010-12-28..2011-01-03,DateSpan 2011-01-04..2011-01-10,DateSpan 2011-01-11..2011-01-17]
2024-09-04 17:28:27 +03:00
-- >>> t (MonthAndDay 11 29) 2012 10 01 2013 10 15
2024-09-04 16:59:14 +03:00
-- [DateSpan 2012-11-29..2013-11-28]
2016-05-07 04:05:42 +03:00
--
2023-01-13 05:19:52 +03:00
splitSpan :: Bool -> Interval -> DateSpan -> [ DateSpan ]
2024-09-04 17:28:27 +03:00
splitSpan _ _ ( DateSpan Nothing Nothing ) = [ DateSpan Nothing Nothing ]
splitSpan _ _ ds | isEmptySpan ds = []
splitSpan _ _ ds @ ( DateSpan ( Just s ) ( Just e ) ) | s == e = [ ds ]
splitSpan _ NoInterval ds = [ ds ]
splitSpan _ ( Days n ) ds = splitspan id addDays n ds
splitSpan adjust ( Weeks n ) ds = splitspan ( if adjust then startofweek else id ) addDays ( 7 * n ) ds
splitSpan adjust ( Months n ) ds = splitspan ( if adjust then startofmonth else id ) addGregorianMonthsClip n ds
splitSpan adjust ( Quarters n ) ds = splitspan ( if adjust then startofquarter else id ) addGregorianMonthsClip ( 3 * n ) ds
splitSpan adjust ( Years n ) ds = splitspan ( if adjust then startofyear else id ) addGregorianYearsClip n ds
splitSpan adjust ( NthWeekdayOfMonth n wd ) ds = splitspan ( if adjust then prevstart else nextstart ) advancemonths 1 ds
2021-07-31 00:28:30 +03:00
where
2024-09-04 17:28:27 +03:00
prevstart = prevNthWeekdayOfMonth n wd
nextstart = nextNthWeekdayOfMonth n wd
2022-01-04 17:38:21 +03:00
advancemonths 0 = id
2024-09-04 16:59:14 +03:00
advancemonths m = advanceToNthWeekday n wd . startofmonth . addGregorianMonthsClip m
2024-09-04 17:28:27 +03:00
splitSpan _ ( MonthDay dom ) ds = splitspan ( nextnthdayofmonth dom ) ( addGregorianMonthsToMonthday dom ) 1 ds
splitSpan _ ( MonthAndDay m d ) ds = splitspan ( nextmonthandday m d ) ( addGregorianYearsClip ) 1 ds
splitSpan _ ( DaysOfWeek [] ) ds = [ ds ]
splitSpan _ ( DaysOfWeek days @ ( n : _ ) ) ds = spansFromBoundaries e bdrys
2022-01-04 17:38:21 +03:00
where
( s , e ) = dateSpanSplitLimits ( nthdayofweekcontaining n ) nextday ds
bdrys = concatMap ( flip map starts . addDays ) [ 0 , 7 .. ]
-- The first representative of each weekday
starts = map ( \ d -> addDays ( toInteger $ d - n ) $ nthdayofweekcontaining n s ) days
2011-01-14 07:32:08 +03:00
2023-05-04 03:58:32 +03:00
-- Like addGregorianMonthsClip, add one month to the given date, clipping when needed
-- to fit it within the next month's length. But also, keep a target day of month in mind,
-- and revert to that or as close to it as possible in subsequent longer months.
-- Eg, using it to step through 31sts gives 1/31, 2/28, 3/31, 4/30, 5/31..
addGregorianMonthsToMonthday :: MonthDay -> Integer -> Day -> Day
addGregorianMonthsToMonthday dom n d =
let ( y , m , _ ) = toGregorian $ addGregorianMonthsClip n d
in fromGregorian y m dom
2023-01-19 12:02:09 +03:00
-- Split the given span into exact spans using the provided helper functions:
2024-09-04 16:59:14 +03:00
--
-- 1. The start function is used to adjust the provided span's start date to get the first sub-span's start date.
--
-- 2. The next function is used to calculate subsequent sub-spans' start dates, possibly with stride increased by a multiplier.
-- It should handle spans of varying length, eg when splitting on "every 31st of month",
-- it adjusts to 28/29/30 in short months but returns to 31 in the long months.
--
2022-01-04 17:38:21 +03:00
splitspan :: ( Day -> Day ) -> ( Integer -> Day -> Day ) -> Int -> DateSpan -> [ DateSpan ]
2024-09-04 16:59:14 +03:00
splitspan start next mult ds = spansFromBoundaries e bdrys
2022-01-04 17:38:21 +03:00
where
2024-09-04 16:59:14 +03:00
( s , e ) = dateSpanSplitLimits start ( next ( toInteger mult ) ) ds
bdrys = mapM ( next . toInteger ) [ 0 , mult .. ] $ start s
2022-01-04 17:38:21 +03:00
2023-01-19 12:02:09 +03:00
-- | Fill in missing start/end dates for calculating 'splitSpan'.
2022-01-04 17:38:21 +03:00
dateSpanSplitLimits :: ( Day -> Day ) -> ( Day -> Day ) -> DateSpan -> ( Day , Day )
2023-01-19 12:02:09 +03:00
dateSpanSplitLimits start _ ( DateSpan ( Just s ) ( Just e ) ) = ( start $ fromEFDay s , fromEFDay e )
dateSpanSplitLimits start next ( DateSpan ( Just s ) Nothing ) = ( start $ fromEFDay s , next $ start $ fromEFDay s )
dateSpanSplitLimits start next ( DateSpan Nothing ( Just e ) ) = ( start $ fromEFDay e , next $ start $ fromEFDay e )
dateSpanSplitLimits _ _ ( DateSpan Nothing Nothing ) = error " dateSpanSplitLimits: should not be nulldatespan " -- PARTIAL: This case should have been handled in splitSpan
2022-01-04 17:38:21 +03:00
2023-01-19 12:02:09 +03:00
-- | Construct a list of exact 'DateSpan's from a list of boundaries, which fit within a given range.
2022-01-04 17:38:21 +03:00
spansFromBoundaries :: Day -> [ Day ] -> [ DateSpan ]
2023-01-19 12:02:09 +03:00
spansFromBoundaries e bdrys = zipWith ( DateSpan ` on ` ( Just . Exact ) ) ( takeWhile ( < e ) bdrys ) $ drop 1 bdrys
2009-05-29 14:02:14 +04:00
-- | Count the days in a DateSpan, or if it is open-ended return Nothing.
daysInSpan :: DateSpan -> Maybe Integer
2023-01-19 12:02:09 +03:00
daysInSpan ( DateSpan ( Just d1 ) ( Just d2 ) ) = Just $ diffDays ( fromEFDay d2 ) ( fromEFDay d1 )
2009-05-29 14:02:14 +04:00
daysInSpan _ = Nothing
2010-07-11 22:56:36 +04:00
2018-03-29 20:09:15 +03:00
-- | Is this an empty span, ie closed with the end date on or before the start date ?
isEmptySpan :: DateSpan -> Bool
2019-11-12 04:14:21 +03:00
isEmptySpan ( DateSpan ( Just s ) ( Just e ) ) = e <= s
isEmptySpan _ = False
2018-03-29 20:09:15 +03:00
2010-07-11 22:56:36 +04:00
-- | Does the span include the given date ?
spanContainsDate :: DateSpan -> Day -> Bool
spanContainsDate ( DateSpan Nothing Nothing ) _ = True
2023-01-19 12:02:09 +03:00
spanContainsDate ( DateSpan Nothing ( Just e ) ) d = d < fromEFDay e
spanContainsDate ( DateSpan ( Just b ) Nothing ) d = d >= fromEFDay b
spanContainsDate ( DateSpan ( Just b ) ( Just e ) ) d = d >= fromEFDay b && d < fromEFDay e
2014-09-11 00:07:53 +04:00
2016-12-03 02:36:23 +03:00
-- | Does the period include the given date ?
-- (Here to avoid import cycle).
periodContainsDate :: Period -> Day -> Bool
periodContainsDate p = spanContainsDate ( periodAsDateSpan p )
2021-09-17 09:15:32 +03:00
-- | Group elements based on where they fall in a list of 'DateSpan's without
-- gaps. The precondition is not checked.
groupByDateSpan :: Bool -> ( a -> Day ) -> [ DateSpan ] -> [ a ] -> [ ( DateSpan , [ a ] ) ]
groupByDateSpan showempty date colspans =
groupByCols colspans
. dropWhile ( beforeStart . fst )
. sortBy ( comparing fst )
. map ( \ x -> ( date x , x ) )
where
groupByCols [] _ = []
groupByCols ( c : cs ) [] = if showempty then ( c , [] ) : groupByCols cs [] else []
2024-03-02 07:07:13 +03:00
groupByCols ( c : cs ) ps = ( c , map snd colps ) : groupByCols cs laterps
where ( colps , laterps ) = span ( ( spanEnd c > ) . Just . fst ) ps
2021-09-17 09:15:32 +03:00
2023-08-25 14:13:02 +03:00
beforeStart = maybe ( const False ) ( > ) $ spanStart =<< headMay colspans
2021-09-17 09:15:32 +03:00
2012-05-19 06:56:26 +04:00
-- | Calculate the intersection of a number of datespans.
spansIntersect [] = nulldatespan
spansIntersect [ d ] = d
spansIntersect ( d : ds ) = d ` spanIntersect ` ( spansIntersect ds )
2024-03-02 07:07:13 +03:00
-- | Calculate the union of a number of datespans.
spansUnion [] = nulldatespan
spansUnion [ d ] = d
spansUnion ( d : ds ) = d ` spanUnion ` ( spansUnion ds )
2011-09-23 04:09:39 +04:00
-- | Calculate the intersection of two datespans.
2018-03-29 20:09:15 +03:00
--
-- For non-intersecting spans, gives an empty span beginning on the second's start date:
2023-01-19 12:02:09 +03:00
-- >>> DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 03) `spanIntersect` DateSpan (Just $ Flex $ fromGregorian 2018 01 03) (Just $ Flex $ fromGregorian 2018 01 05)
2020-03-22 15:51:18 +03:00
-- DateSpan 2018-01-03..2018-01-02
2024-03-02 07:07:13 +03:00
spanIntersect ( DateSpan b1 e1 ) ( DateSpan b2 e2 ) = DateSpan ( laterDefinite b1 b2 ) ( earlierDefinite e1 e2 )
2011-09-23 04:09:39 +04:00
2014-04-19 19:38:03 +04:00
-- | Fill any unspecified dates in the first span with the dates from
2024-03-02 07:07:13 +03:00
-- the second one (if specified there). Sort of a one-way spanIntersect.
2014-04-19 19:38:03 +04:00
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
2012-05-19 06:56:26 +04:00
-- | Calculate the union of two datespans.
2024-03-02 07:07:13 +03:00
-- If either span is open-ended, the union will be too.
--
-- >>> ys2024 = fromGregorian 2024 01 01
-- >>> ys2025 = fromGregorian 2025 01 01
-- >>> to2024 = DateSpan Nothing (Just $ Exact ys2024)
-- >>> in2024 = DateSpan (Just $ Exact ys2024) (Just $ Exact ys2025)
-- >>> spanUnion to2024 in2024
-- DateSpan ..2024-12-31
-- >>> spanUnion in2024 to2024
-- DateSpan ..2024-12-31
spanUnion ( DateSpan b1 e1 ) ( DateSpan b2 e2 ) = DateSpan ( earlier b1 b2 ) ( later e1 e2 )
-- | Extend the first span to include any definite end dates of the second.
-- Unlike spanUnion, open ends in the second are ignored.
-- If the first span was open-ended, it still will be after being extended.
--
-- >>> ys2024 = fromGregorian 2024 01 01
-- >>> ys2025 = fromGregorian 2025 01 01
-- >>> to2024 = DateSpan Nothing (Just $ Exact ys2024)
-- >>> all2024 = DateSpan (Just $ Exact ys2024) (Just $ Exact ys2025)
-- >>> partof2024 = DateSpan (Just $ Exact $ fromGregorian 2024 03 01) (Just $ Exact $ fromGregorian 2024 09 01)
-- >>> spanExtend to2024 all2024
-- DateSpan 2024
-- >>> spanExtend all2024 to2024
-- DateSpan 2024
-- >>> spanExtend partof2024 all2024
-- DateSpan 2024
-- >>> spanExtend all2024 partof2024
-- DateSpan 2024
--
spanExtend ( DateSpan b1 e1 ) ( DateSpan b2 e2 ) = DateSpan ( earlierDefinite b1 b2 ) ( laterDefinite e1 e2 )
-- | Pick the earlier of two DateSpan starts, treating Nothing as infinitely early.
-- An Exact and Flex with the same date are considered equal; the first argument wins.
earlier :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
earlier = min
-- | Pick the later of two DateSpan starts, treating Nothing as infinitely late.
-- An Exact and Flex with the same date are considered equal; the second argument wins.
later :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
later _ Nothing = Nothing
later Nothing _ = Nothing
later d1 d2 = max d1 d2
-- | Pick the earlier of two DateSpan ends that is a definite date (if any).
-- An Exact and Flex with the same date are considered equal; the first argument wins.
earlierDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
earlierDefinite d1 Nothing = d1
earlierDefinite Nothing d2 = d2
earlierDefinite d1 d2 = min d1 d2
-- | Pick the later of two DateSpan ends that is a definite date (if any).
-- An Exact and Flex with the same date are considered equal; the second argument wins.
laterDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
laterDefinite d1 Nothing = d1
laterDefinite Nothing d2 = d2
laterDefinite d1 d2 = max d1 d2
2011-09-23 04:09:39 +04:00
2019-11-12 04:14:21 +03:00
-- | Calculate the minimal DateSpan containing all of the given Days (in the
-- usual exclusive-end-date sense: beginning on the earliest, and ending on
-- the day after the latest).
daysSpan :: [ Day ] -> DateSpan
2023-01-19 12:02:09 +03:00
daysSpan ds = DateSpan ( Exact <$> minimumMay ds ) ( Exact . addDays 1 <$> maximumMay ds )
2019-11-12 04:14:21 +03:00
-- | Select the DateSpan containing a given Day, if any, from a given list of
-- DateSpans.
--
-- If the DateSpans are non-overlapping, this returns the unique containing
-- DateSpan, if it exists. If the DateSpans are overlapping, it will return the
-- containing DateSpan with the latest start date, and then latest end date.
-- Note: This will currently return `DateSpan (Just s) (Just e)` before it will
-- return `DateSpan (Just s) Nothing`. It's unclear which behaviour is desired.
-- This is irrelevant at the moment as it's never applied to any list with
-- overlapping DateSpans.
latestSpanContaining :: [ DateSpan ] -> Day -> Maybe DateSpan
latestSpanContaining datespans = go
where
go day = do
2022-08-23 13:58:31 +03:00
spn <- Set . lookupLT supSpan spanSet
guard $ spanContainsDate spn day
return spn
2019-11-12 04:14:21 +03:00
where
-- The smallest DateSpan larger than any DateSpan containing day.
2023-01-19 12:02:09 +03:00
supSpan = DateSpan ( Just $ Exact $ addDays 1 day ) Nothing
2019-11-12 04:14:21 +03:00
spanSet = Set . fromList $ filter ( not . isEmptySpan ) datespans
2008-12-04 02:20:38 +03:00
-- | Parse a period expression to an Interval and overall DateSpan using
2010-08-01 04:15:21 +04:00
-- the provided reference date, or return a parse error.
2018-09-30 04:32:08 +03:00
parsePeriodExpr
2022-03-20 22:00:47 +03:00
:: Day -> Text -> Either HledgerParseErrors ( Interval , DateSpan )
2018-06-09 05:35:27 +03:00
parsePeriodExpr refdate s = parsewith ( periodexprp refdate <* eof ) ( T . toLower s )
-- | Like parsePeriodExpr, but call error' on failure.
parsePeriodExpr' :: Day -> Text -> ( Interval , DateSpan )
parsePeriodExpr' refdate s =
2020-08-06 02:05:56 +03:00
either ( error ' . ( " f a i l e d t o p a r s e : " + + ) . c u s t o m E r r o r B u n d l e P r e t t y ) i d $ - - P A R T I A L :
2018-06-09 05:35:27 +03:00
parsePeriodExpr refdate s
2010-08-01 04:15:21 +04:00
-- | Show a DateSpan as a human-readable pseudo-period-expression string.
2012-05-07 00:42:34 +04:00
-- dateSpanAsText :: DateSpan -> String
-- dateSpanAsText (DateSpan Nothing Nothing) = "all"
-- dateSpanAsText (DateSpan Nothing (Just e)) = printf "to %s" (show e)
-- dateSpanAsText (DateSpan (Just b) Nothing) = printf "from %s" (show b)
-- dateSpanAsText (DateSpan (Just b) (Just e)) = printf "%s to %s" (show b) (show e)
2014-09-11 00:07:53 +04:00
2008-12-04 02:20:38 +03:00
-- | Convert a single smart date string to a date span using the provided
2010-03-09 20:38:12 +03:00
-- reference date, or raise an error.
2012-05-07 00:42:34 +04:00
-- spanFromSmartDateString :: Day -> String -> DateSpan
-- spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate
-- where
-- sdate = fromparse $ parsewith smartdateonly s
2008-11-27 22:42:03 +03:00
spanFromSmartDate :: Day -> SmartDate -> DateSpan
spanFromSmartDate refdate sdate = DateSpan ( Just b ) ( Just e )
where
2009-06-05 13:44:20 +04:00
( ry , rm , _ ) = toGregorian refdate
2022-08-23 13:58:31 +03:00
( b , e ) = span' sdate
where
2023-01-19 12:02:09 +03:00
span' :: SmartDate -> ( EFDay , EFDay )
span' ( SmartCompleteDate day ) = ( Exact day , Exact $ nextday day )
span' ( SmartAssumeStart y Nothing ) = ( Flex $ startofyear day , Flex $ nextyear day ) where day = fromGregorian y 1 1
span' ( SmartAssumeStart y ( Just m ) ) = ( Flex $ startofmonth day , Flex $ nextmonth day ) where day = fromGregorian y m 1
span' ( SmartFromReference m d ) = ( Exact day , Exact $ nextday day ) where day = fromGregorian ry ( fromMaybe rm m ) d
span' ( SmartMonth m ) = ( Flex $ startofmonth day , Flex $ nextmonth day ) where day = fromGregorian ry m 1
span' ( SmartRelative n Day ) = ( Exact $ addDays n refdate , Exact $ addDays ( n + 1 ) refdate )
span' ( SmartRelative n Week ) = ( Flex $ addDays ( 7 * n ) d , Flex $ addDays ( 7 * n + 7 ) d ) where d = thisweek refdate
span' ( SmartRelative n Month ) = ( Flex $ addGregorianMonthsClip n d , Flex $ addGregorianMonthsClip ( n + 1 ) d ) where d = thismonth refdate
span' ( SmartRelative n Quarter ) = ( Flex $ addGregorianMonthsClip ( 3 * n ) d , Flex $ addGregorianMonthsClip ( 3 * n + 3 ) d ) where d = thisquarter refdate
span' ( SmartRelative n Year ) = ( Flex $ addGregorianYearsClip n d , Flex $ addGregorianYearsClip ( n + 1 ) d ) where d = thisyear refdate
2008-11-27 09:29:29 +03:00
2012-05-07 00:42:34 +04:00
-- showDay :: Day -> String
-- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day
2010-03-09 21:33:26 +03:00
2009-12-13 01:19:57 +03:00
-- | Convert a smart date string to an explicit yyyy\/mm\/dd string using
2010-03-09 20:38:12 +03:00
-- the provided reference date, or raise an error.
2020-11-05 04:58:04 +03:00
fixSmartDateStr :: Day -> Text -> Text
2019-02-14 16:14:52 +03:00
fixSmartDateStr d s =
2020-08-06 02:05:56 +03:00
either ( error ' . p r i n t f " c o u l d n o t p a r s e d a t e % s % s " ( s h o w s ) . s h o w ) i d $ - - P A R T I A L :
2022-03-20 22:00:47 +03:00
( fixSmartDateStrEither d s :: Either HledgerParseErrors Text )
2010-03-09 21:33:26 +03:00
-- | A safe version of fixSmartDateStr.
2022-03-20 22:00:47 +03:00
fixSmartDateStrEither :: Day -> Text -> Either HledgerParseErrors Text
2023-01-19 12:02:09 +03:00
fixSmartDateStrEither d = fmap showEFDate . fixSmartDateStrEither' d
2011-08-15 02:39:48 +04:00
2024-06-07 14:03:26 +03:00
fixSmartDateStrEither' :: Day -> Text -> Either HledgerParseErrors EFDay
2016-07-29 18:57:10 +03:00
fixSmartDateStrEither' d s = case parsewith smartdateonly ( T . toLower s ) of
2011-08-15 02:39:48 +04:00
Right sd -> Right $ fixSmartDate d sd
Left e -> Left e
2008-11-27 03:35:00 +03:00
2023-01-19 12:02:09 +03:00
-- | Convert a SmartDate to a specific date using the provided reference date.
-- This date will be exact or flexible depending on whether the day was
-- specified exactly. (Missing least-significant parts produces a flex date.)
2016-05-07 04:05:42 +03:00
--
-- ==== Examples:
2016-12-29 22:15:01 +03:00
-- >>> :set -XOverloadedStrings
2020-08-26 11:11:20 +03:00
-- >>> let t = fixSmartDateStr (fromGregorian 2008 11 26)
2016-05-07 04:05:42 +03:00
-- >>> t "0000-01-01"
2020-02-03 19:03:44 +03:00
-- "0000-01-01"
2016-05-07 04:05:42 +03:00
-- >>> t "1999-12-02"
2020-02-03 19:03:44 +03:00
-- "1999-12-02"
2016-05-07 04:05:42 +03:00
-- >>> t "1999.12.02"
2020-02-03 19:03:44 +03:00
-- "1999-12-02"
2016-05-07 04:05:42 +03:00
-- >>> t "1999/3/2"
2020-02-03 19:03:44 +03:00
-- "1999-03-02"
2016-05-07 04:05:42 +03:00
-- >>> t "19990302"
2020-02-03 19:03:44 +03:00
-- "1999-03-02"
2016-05-07 04:05:42 +03:00
-- >>> t "2008/2"
2020-02-03 19:03:44 +03:00
-- "2008-02-01"
2016-05-07 04:05:42 +03:00
-- >>> t "0020/2"
2020-02-03 19:03:44 +03:00
-- "0020-02-01"
2016-05-07 04:05:42 +03:00
-- >>> t "1000"
2020-02-03 19:03:44 +03:00
-- "1000-01-01"
2016-05-07 04:05:42 +03:00
-- >>> t "4/2"
2020-02-03 19:03:44 +03:00
-- "2008-04-02"
2016-05-07 04:05:42 +03:00
-- >>> t "2"
2020-02-03 19:03:44 +03:00
-- "2008-11-02"
2016-05-07 04:05:42 +03:00
-- >>> t "January"
2020-02-03 19:03:44 +03:00
-- "2008-01-01"
2016-05-07 04:05:42 +03:00
-- >>> t "feb"
2020-02-03 19:03:44 +03:00
-- "2008-02-01"
2016-05-07 04:05:42 +03:00
-- >>> t "today"
2020-02-03 19:03:44 +03:00
-- "2008-11-26"
2016-05-07 04:05:42 +03:00
-- >>> t "yesterday"
2020-02-03 19:03:44 +03:00
-- "2008-11-25"
2016-05-07 04:05:42 +03:00
-- >>> t "tomorrow"
2020-02-03 19:03:44 +03:00
-- "2008-11-27"
2016-05-07 04:05:42 +03:00
-- >>> t "this day"
2020-02-03 19:03:44 +03:00
-- "2008-11-26"
2016-05-07 04:05:42 +03:00
-- >>> t "last day"
2020-02-03 19:03:44 +03:00
-- "2008-11-25"
2016-05-07 04:05:42 +03:00
-- >>> t "next day"
2020-02-03 19:03:44 +03:00
-- "2008-11-27"
2016-05-07 04:05:42 +03:00
-- >>> t "this week" -- last monday
2020-02-03 19:03:44 +03:00
-- "2008-11-24"
2016-05-07 04:05:42 +03:00
-- >>> t "last week" -- previous monday
2020-02-03 19:03:44 +03:00
-- "2008-11-17"
2016-05-07 04:05:42 +03:00
-- >>> t "next week" -- next monday
2020-02-03 19:03:44 +03:00
-- "2008-12-01"
2016-05-07 04:05:42 +03:00
-- >>> t "this month"
2020-02-03 19:03:44 +03:00
-- "2008-11-01"
2016-05-07 04:05:42 +03:00
-- >>> t "last month"
2020-02-03 19:03:44 +03:00
-- "2008-10-01"
2016-05-07 04:05:42 +03:00
-- >>> t "next month"
2020-02-03 19:03:44 +03:00
-- "2008-12-01"
2016-05-07 04:05:42 +03:00
-- >>> t "this quarter"
2020-02-03 19:03:44 +03:00
-- "2008-10-01"
2016-05-07 04:05:42 +03:00
-- >>> t "last quarter"
2020-02-03 19:03:44 +03:00
-- "2008-07-01"
2016-05-07 04:05:42 +03:00
-- >>> t "next quarter"
2020-02-03 19:03:44 +03:00
-- "2009-01-01"
2016-05-07 04:05:42 +03:00
-- >>> t "this year"
2020-02-03 19:03:44 +03:00
-- "2008-01-01"
2016-05-07 04:05:42 +03:00
-- >>> t "last year"
2020-02-03 19:03:44 +03:00
-- "2007-01-01"
2016-05-07 04:05:42 +03:00
-- >>> t "next year"
2020-02-03 19:03:44 +03:00
-- "2009-01-01"
2016-05-07 04:05:42 +03:00
--
-- t "last wed"
2020-02-03 19:03:44 +03:00
-- "2008-11-19"
2016-05-07 04:05:42 +03:00
-- t "next friday"
2020-02-03 19:03:44 +03:00
-- "2008-11-28"
2016-05-07 04:05:42 +03:00
-- t "next january"
2020-02-03 19:03:44 +03:00
-- "2009-01-01"
2016-05-07 04:05:42 +03:00
--
2021-12-20 16:36:33 +03:00
-- >>> t "in 5 days"
-- "2008-12-01"
-- >>> t "in 7 months"
-- "2009-06-01"
-- >>> t "in -2 weeks"
-- "2008-11-10"
-- >>> t "1 quarter ago"
-- "2008-07-01"
-- >>> t "1 week ahead"
-- "2008-12-01"
2023-01-19 12:02:09 +03:00
fixSmartDate :: Day -> SmartDate -> EFDay
2019-02-14 16:14:52 +03:00
fixSmartDate refdate = fix
where
2023-01-19 12:02:09 +03:00
fix :: SmartDate -> EFDay
fix ( SmartCompleteDate d ) = Exact d
fix ( SmartAssumeStart y m ) = Flex $ fromGregorian y ( fromMaybe 1 m ) 1
fix ( SmartFromReference m d ) = Exact $ fromGregorian ry ( fromMaybe rm m ) d
fix ( SmartMonth m ) = Flex $ fromGregorian ry m 1
fix ( SmartRelative n Day ) = Exact $ addDays n refdate
fix ( SmartRelative n Week ) = Flex $ addDays ( 7 * n ) $ thisweek refdate
fix ( SmartRelative n Month ) = Flex $ addGregorianMonthsClip n $ thismonth refdate
fix ( SmartRelative n Quarter ) = Flex $ addGregorianMonthsClip ( 3 * n ) $ thisquarter refdate
fix ( SmartRelative n Year ) = Flex $ addGregorianYearsClip n $ thisyear refdate
2020-07-21 06:48:55 +03:00
( ry , rm , _ ) = toGregorian refdate
2008-11-27 03:35:00 +03:00
2008-11-27 05:49:22 +03:00
prevday :: Day -> Day
prevday = addDays ( - 1 )
nextday = addDays 1
2008-11-27 04:49:13 +03:00
2008-11-27 05:49:22 +03:00
thisweek = startofweek
prevweek = startofweek . addDays ( - 7 )
nextweek = startofweek . addDays 7
startofweek day = fromMondayStartWeek y w 1
2008-11-27 04:49:13 +03:00
where
2008-11-27 05:49:22 +03:00
( y , _ , _ ) = toGregorian day
2008-11-27 04:49:13 +03:00
( w , _ ) = mondayStartWeek day
2008-11-27 05:49:22 +03:00
thismonth = startofmonth
prevmonth = startofmonth . addGregorianMonthsClip ( - 1 )
nextmonth = startofmonth . addGregorianMonthsClip 1
startofmonth day = fromGregorian y m 1 where ( y , m , _ ) = toGregorian day
2017-11-25 01:44:10 +03:00
nthdayofmonth d day = fromGregorian y m d where ( y , m , _ ) = toGregorian day
2008-11-27 05:49:22 +03:00
thisquarter = startofquarter
startofquarter day = fromGregorian y ( firstmonthofquarter m ) 1
where
( y , m , _ ) = toGregorian day
2022-08-23 13:58:31 +03:00
firstmonthofquarter m2 = ( ( m2 - 1 ) ` div ` 3 ) * 3 + 1
2008-11-27 05:49:22 +03:00
thisyear = startofyear
2024-09-04 16:59:14 +03:00
-- prevyear = startofyear . addGregorianYearsClip (-1)
2008-11-27 05:49:22 +03:00
nextyear = startofyear . addGregorianYearsClip 1
startofyear day = fromGregorian y 1 1 where ( y , _ , _ ) = toGregorian day
2008-11-27 03:35:00 +03:00
2023-01-13 05:19:52 +03:00
-- Get the natural start for the given interval that falls on or before the given day,
-- when applicable. Works for Weeks, Months, Quarters, Years, eg.
2023-01-11 20:32:59 +03:00
intervalBoundaryBefore :: Interval -> Day -> Day
2023-01-13 05:19:52 +03:00
intervalBoundaryBefore i d =
2023-01-19 12:02:09 +03:00
case splitSpan True i ( DateSpan ( Just $ Exact d ) ( Just $ Exact $ addDays 1 d ) ) of
( DateSpan ( Just start ) _ : _ ) -> fromEFDay start
2022-07-09 11:59:17 +03:00
_ -> d
2024-09-04 16:59:14 +03:00
-- | Find the next occurrence of the specified month and day of month, on or after the given date.
-- The month should be 1-12 and the day of month should be 1-31, or an error will be raised.
2017-11-25 01:43:53 +03:00
--
2020-08-26 11:11:20 +03:00
-- >>> let wed22nd = fromGregorian 2017 11 22
2024-09-04 16:59:14 +03:00
-- >>> nextmonthandday 11 21 wed22nd
-- 2018-11-21
-- >>> nextmonthandday 11 22 wed22nd
2019-07-15 13:28:52 +03:00
-- 2017-11-22
2024-09-04 16:59:14 +03:00
-- >>> nextmonthandday 11 23 wed22nd
-- 2017-11-23
nextmonthandday :: Month -> MonthDay -> Day -> Day
nextmonthandday m n date
2020-08-06 02:05:56 +03:00
-- PARTIAL:
2024-09-04 16:59:14 +03:00
| not ( validMonth m ) = error ' $ " n e x t m o n t h a n d d a y : m o n t h s h o u l d b e 1 . . 1 2 , n o t " + + s h o w m
| not ( validDay n ) = error ' $ " n e x t m o n t h a n d d a y : d a y s h o u l d b e 1 . . 3 1 , n o t " + + s h o w n
| mdthisyear >= date = mdthisyear
| otherwise = mdnextyear
where
s = startofyear date
advancetomonth = applyN ( m - 1 ) nextmonth
advancetoday = addDays ( toInteger n - 1 )
mdthisyear = advancetoday $ advancetomonth s
mdnextyear = advancetoday $ advancetomonth $ nextyear s
-- | Find the next occurrence of the specified day of month, on or after the given date.
-- The day of month should be 1-31, or an error will be raised.
2017-11-25 00:51:51 +03:00
--
2020-08-26 11:11:20 +03:00
-- >>> let wed22nd = fromGregorian 2017 11 22
2024-08-30 01:07:24 +03:00
-- >>> nextnthdayofmonth 21 wed22nd
-- 2017-12-21
-- >>> nextnthdayofmonth 22 wed22nd
2019-07-15 13:28:52 +03:00
-- 2017-11-22
2024-08-30 01:07:24 +03:00
-- >>> nextnthdayofmonth 23 wed22nd
-- 2017-11-23
nextnthdayofmonth :: MonthDay -> Day -> Day
nextnthdayofmonth n date
2020-08-06 02:05:56 +03:00
-- PARTIAL:
2024-08-30 01:07:24 +03:00
| not ( validDay n ) = error ' $ " n e x t n t h d a y o f m o n t h : d a y s h o u l d b e 1 . . 3 1 , n o t " + + s h o w n
| nthofthismonth >= date = nthofthismonth
| otherwise = nthofnextmonth
where
s = startofmonth date
nthofthismonth = nthdayofmonth n s
nthofnextmonth = nthdayofmonth n $ nextmonth s
2011-01-14 07:32:08 +03:00
2017-11-25 00:51:51 +03:00
-- | For given date d find week-long interval that starts on nth day of week
2019-07-15 13:28:52 +03:00
-- and covers it.
2017-11-25 00:51:51 +03:00
--
-- Examples: 2017-11-22 is Wed. Week-long intervals that cover it and
-- start on Mon, Tue or Wed will start in the same week. However
2019-07-15 13:28:52 +03:00
-- intervals that start on Thu or Fri should start in prev week:
2020-08-26 11:11:20 +03:00
-- >>> let wed22nd = fromGregorian 2017 11 22
2017-11-25 00:51:51 +03:00
-- >>> nthdayofweekcontaining 1 wed22nd
2019-07-15 13:28:52 +03:00
-- 2017-11-20
2017-11-25 00:51:51 +03:00
-- >>> nthdayofweekcontaining 2 wed22nd
-- 2017-11-21
-- >>> nthdayofweekcontaining 3 wed22nd
2019-07-15 13:28:52 +03:00
-- 2017-11-22
2017-11-25 00:51:51 +03:00
-- >>> nthdayofweekcontaining 4 wed22nd
2019-07-15 13:28:52 +03:00
-- 2017-11-16
2017-11-25 00:51:51 +03:00
-- >>> nthdayofweekcontaining 5 wed22nd
2019-07-15 13:28:52 +03:00
-- 2017-11-17
2018-07-24 16:24:45 +03:00
nthdayofweekcontaining :: WeekDay -> Day -> Day
2017-11-25 00:51:51 +03:00
nthdayofweekcontaining n d | nthOfSameWeek <= d = nthOfSameWeek
| otherwise = nthOfPrevWeek
2020-08-09 15:59:04 +03:00
where nthOfSameWeek = addDays ( toInteger n - 1 ) s
nthOfPrevWeek = addDays ( toInteger n - 1 ) $ prevweek s
2011-01-14 07:32:08 +03:00
s = startofweek d
2024-09-04 16:59:14 +03:00
-- -- | Find the next occurrence of some weekday, on or after the given date d.
-- --
-- -- >>> let wed22nd = fromGregorian 2017 11 22
-- -- >>> nextnthdayofweek 1 wed22nd
-- -- 2017-11-20
-- -- >>> nextnthdayofweek 2 wed22nd
-- -- 2017-11-21
-- -- >>> nextnthdayofweek 3 wed22nd
-- -- 2017-11-22
-- -- >>> nextnthdayofweek 4 wed22nd
-- -- 2017-11-16
-- -- >>> nextnthdayofweek 5 wed22nd
-- -- 2017-11-17
-- nextdayofweek :: WeekDay -> Day -> Day
-- nextdayofweek n d | nthOfSameWeek <= d = nthOfSameWeek
-- | otherwise = nthOfPrevWeek
-- where nthOfSameWeek = addDays (toInteger n-1) s
-- nthOfPrevWeek = addDays (toInteger n-1) $ prevweek s
-- s = startofweek d
-- | Find the next occurrence of some nth weekday of a month, on or after the given date d.
2017-11-25 02:52:34 +03:00
--
2020-08-26 11:11:20 +03:00
-- >>> let wed22nd = fromGregorian 2017 11 22
2024-09-04 16:59:14 +03:00
-- >>> nextNthWeekdayOfMonth 3 3 wed22nd -- next third wednesday
-- 2017-12-20
-- >>> nextNthWeekdayOfMonth 4 3 wed22nd -- next fourth wednesday
2017-11-25 02:52:34 +03:00
-- 2017-11-22
2024-09-04 16:59:14 +03:00
-- >>> nextNthWeekdayOfMonth 5 3 wed22nd -- next fifth wednesday
-- 2017-11-29
nextNthWeekdayOfMonth :: Int -> WeekDay -> Day -> Day
nextNthWeekdayOfMonth n wd d
| nthweekdaythismonth >= d = nthweekdaythismonth
| otherwise = nthweekdaynextmonth
where
nthweekdaythismonth = advanceToNthWeekday n wd $ startofmonth d
nthweekdaynextmonth = advanceToNthWeekday n wd $ nextmonth d
-- | Find the previous occurrence of some nth weekday of a month, on or before the given date d.
--
-- >>> let wed22nd = fromGregorian 2017 11 22
-- >>> prevNthWeekdayOfMonth 4 3 wed22nd
-- 2017-11-22
-- >>> prevNthWeekdayOfMonth 5 2 wed22nd
-- 2017-10-31
prevNthWeekdayOfMonth :: Int -> WeekDay -> Day -> Day
prevNthWeekdayOfMonth n wd d
| nthweekdaythismonth <= d = nthweekdaythismonth
| otherwise = nthweekdayprevmonth
where
nthweekdaythismonth = advanceToNthWeekday n wd $ startofmonth d
nthweekdayprevmonth = advanceToNthWeekday n wd $ prevmonth d
-- | Advance to the nth occurrence of the given weekday, on or after the given date.
2020-08-06 02:05:56 +03:00
-- Can call error.
2024-09-04 16:59:14 +03:00
advanceToNthWeekday :: Int -> WeekDay -> Day -> Day
advanceToNthWeekday n wd s =
2020-08-06 02:05:56 +03:00
-- PARTIAL:
2018-07-24 16:36:45 +03:00
maybe err ( addWeeks ( n - 1 ) ) $ firstMatch ( >= s ) $ iterate ( addWeeks 1 ) $ firstweekday s
where
2024-09-04 16:59:14 +03:00
err = error ' " a d v a n c e T o N t h W e e k d a y : s h o u l d n o t h a p p e n "
2020-08-09 15:59:04 +03:00
addWeeks k = addDays ( 7 * toInteger k )
2019-07-15 13:28:52 +03:00
firstMatch p = headMay . dropWhile ( not . p )
2020-08-09 15:59:04 +03:00
firstweekday = addDays ( toInteger wd - 1 ) . startofweek
2017-11-25 02:52:34 +03:00
2008-11-27 03:35:00 +03:00
----------------------------------------------------------------------
-- parsing
2012-05-07 00:42:34 +04:00
-- -- | Parse a couple of date-time string formats to a time type.
-- parsedatetimeM :: String -> Maybe LocalTime
2020-02-28 10:31:53 +03:00
-- parsedatetimeM s = asum [
2022-04-16 04:02:11 +03:00
-- parseTimeM TruedefaultTimeLocale "%Y/%m/%d %H:%M:%S" s,
-- parseTimeM TruedefaultTimeLocale "%Y-%m-%d %H:%M:%S" s
2012-05-07 00:42:34 +04:00
-- ]
2009-01-11 09:58:35 +03:00
2020-02-27 21:57:55 +03:00
-- | Try to parse a couple of date string formats:
-- `YYYY-MM-DD`, `YYYY/MM/DD` or `YYYY.MM.DD`, with leading zeros required.
-- For internal use, not quite the same as the journal's "simple dates".
2020-08-26 10:16:51 +03:00
-- >>> parsedateM "2008/02/03"
-- Just 2008-02-03
-- >>> parsedateM "2008/02/03/"
-- Nothing
-- >>> parsedateM "2008/02/30"
-- Nothing
2009-01-11 09:58:35 +03:00
parsedateM :: String -> Maybe Day
2020-02-28 10:31:53 +03:00
parsedateM s = asum [
2020-08-26 10:16:51 +03:00
parseTimeM True defaultTimeLocale " %Y-%m-%d " s ,
parseTimeM True defaultTimeLocale " %Y/%m/%d " s ,
parseTimeM True defaultTimeLocale " %Y.%m.%d " s
2009-01-11 09:58:35 +03:00
]
2008-11-11 15:34:05 +03:00
2014-09-11 00:07:53 +04:00
{- |
2018-04-04 19:45:23 +03:00
Parse a date in any of the formats allowed in Ledger's period expressions , and some others .
2008-11-27 03:35:00 +03:00
Assumes any text in the parse stream has been lowercased .
2018-04-04 19:45:23 +03:00
Returns a SmartDate , to be converted to a full date later ( see fixSmartDate ) .
Examples :
> 2004 ( start of year , which must have 4 + digits )
> 2004 / 10 ( start of month , which must be 1 - 12 )
> 2004 / 10 / 1 ( exact date , day must be 1 - 31 )
> 10 / 1 ( month and day in current year )
> 21 ( day in current month )
> october , oct ( start of month in current year )
> yesterday , today , tomorrow ( - 1 , 0 , 1 days from today )
> last / this / next day / week / month / quarter / year ( - 1 , 0 , 1 periods from the current period )
2021-12-20 16:36:33 +03:00
> in n days / weeks / months / quarters / years ( n periods from the current period )
> n days / weeks / months / quarters / years ago ( - n periods from the current period )
2018-04-04 19:45:23 +03:00
> 20181201 ( 8 digit YYYYMMDD with valid year month and day )
> 201812 ( 6 digit YYYYMM with valid year and month )
Note malformed digit sequences might give surprising results :
> 201813 ( 6 digits with an invalid month is parsed as start of 6 - digit year )
> 20181301 ( 8 digits with an invalid month is parsed as start of 8 - digit year )
> 20181232 ( 8 digits with an invalid day gives an error )
> 201801012 ( 9 + digits beginning with a valid YYYYMMDD gives an error )
Eg :
YYYYMMDD is parsed as year - month - date if those parts are valid
( >= 4 digits , 1 - 12 , and 1 - 31 respectively ) :
>>> parsewith ( smartdate <* eof ) " 20181201 "
2022-03-14 16:02:24 +03:00
Right ( SmartCompleteDate 2018 - 12 - 01 )
2018-04-04 19:45:23 +03:00
YYYYMM is parsed as year - month - 01 if year and month are valid :
>>> parsewith ( smartdate <* eof ) " 201804 "
2022-03-14 16:02:24 +03:00
Right ( SmartAssumeStart 2018 ( Just 4 ) )
2018-04-04 19:45:23 +03:00
With an invalid month , it's parsed as a year :
>>> parsewith ( smartdate <* eof ) " 201813 "
2020-08-07 05:18:19 +03:00
Right ( SmartAssumeStart 201813 Nothing )
2018-04-04 19:45:23 +03:00
A 9 + digit number beginning with valid YYYYMMDD gives an error :
>>> parsewith ( smartdate <* eof ) " 201801012 "
2018-05-13 18:10:45 +03:00
Left ( ... )
2018-04-04 19:45:23 +03:00
Big numbers not beginning with a valid YYYYMMDD are parsed as a year :
>>> parsewith ( smartdate <* eof ) " 201813012 "
2020-08-07 05:18:19 +03:00
Right ( SmartAssumeStart 201813012 Nothing )
2018-04-04 19:45:23 +03:00
2008-11-27 03:35:00 +03:00
- }
2018-06-12 22:29:22 +03:00
smartdate :: TextParser m SmartDate
2020-07-21 06:48:55 +03:00
smartdate = choice'
2010-09-04 03:22:58 +04:00
-- XXX maybe obscures date errors ? see ledgerdate
2021-12-20 16:36:33 +03:00
[ relativeP
, yyyymmdd , ymd
2020-08-07 05:18:19 +03:00
, ( \ ( m , d ) -> SmartFromReference ( Just m ) d ) <$> md
2021-08-16 07:49:40 +03:00
, failIfInvalidDate . SmartFromReference Nothing =<< decimal
2020-08-07 05:18:19 +03:00
, SmartMonth <$> ( month <|> mon )
2021-12-20 16:36:33 +03:00
, SmartRelative 0 Day <$ string' " today "
, SmartRelative ( - 1 ) Day <$ string' " yesterday "
, SmartRelative 1 Day <$ string' " tomorrow "
2020-07-21 06:48:55 +03:00
]
where
2021-12-20 16:36:33 +03:00
relativeP = do
optional $ string' " in " <* skipNonNewlineSpaces
num <- seqP <* skipNonNewlineSpaces
interval <- intervalP <* skipNonNewlineSpaces
sign <- choice [ negate <$ string' " ago " , id <$ string' " ahead " , pure id ]
return $ SmartRelative ( sign num ) interval
seqP = choice [ 0 <$ string' " this " , - 1 <$ string' " last " , 1 <$ string' " next " , signed skipNonNewlineSpaces decimal ]
intervalP = choice [ Day <$ string' " day " , Week <$ string' " week " , Month <$ string' " month "
, Quarter <$ string' " quarter " , Year <$ string' " year " ] <* optional ( char' 's' )
2008-11-27 03:35:00 +03:00
2010-03-10 02:11:12 +03:00
-- | Like smartdate, but there must be nothing other than whitespace after the date.
2018-06-12 22:29:22 +03:00
smartdateonly :: TextParser m SmartDate
2020-07-21 06:48:55 +03:00
smartdateonly = smartdate <* skipNonNewlineSpaces <* eof
2010-03-10 02:11:12 +03:00
2019-02-14 16:14:52 +03:00
datesepchars :: String
2010-09-04 03:22:58 +04:00
datesepchars = " /-. "
2018-05-22 04:52:34 +03:00
2016-07-29 18:57:10 +03:00
datesepchar :: TextParser m Char
2018-05-22 04:52:34 +03:00
datesepchar = satisfy isDateSepChar
isDateSepChar :: Char -> Bool
2020-02-08 16:06:52 +03:00
isDateSepChar c = c == '-' || c == '/' || c == '.'
2008-11-27 03:35:00 +03:00
2020-07-21 06:48:55 +03:00
validMonth , validDay :: Int -> Bool
validMonth n = n >= 1 && n <= 12
validDay n = n >= 1 && n <= 31
2010-04-15 01:49:34 +04:00
2020-08-07 05:18:19 +03:00
failIfInvalidDate :: Fail . MonadFail m => SmartDate -> m SmartDate
2021-08-16 07:57:15 +03:00
failIfInvalidDate s = unless isValid ( Fail . fail $ " bad smart date: " ++ show s ) $> s
2020-08-07 05:18:19 +03:00
where isValid = case s of
2022-03-14 16:02:24 +03:00
SmartAssumeStart _ ( Just m ) -> validMonth m
SmartFromReference mm d -> isJust $ fromGregorianValid 2004 ( fromMaybe 1 mm ) d
SmartMonth m -> validMonth m
_ -> True
showBadDate :: Integer -> Int -> Int -> String
showBadDate y m d = " bad smart date: " ++ show y ++ " - " ++ show m ++ " - " ++ show d
2010-04-15 01:49:34 +04:00
2018-06-12 22:29:22 +03:00
yyyymmdd :: TextParser m SmartDate
2009-01-17 23:07:24 +03:00
yyyymmdd = do
2020-07-21 06:48:55 +03:00
y <- read <$> count 4 digitChar
m <- read <$> count 2 digitChar
2022-08-23 13:58:31 +03:00
mdy <- optional $ read <$> count 2 digitChar
case mdy of
2022-03-14 16:02:24 +03:00
Nothing -> failIfInvalidDate $ SmartAssumeStart y ( Just m )
Just d -> maybe ( Fail . fail $ showBadDate y m d ) ( return . SmartCompleteDate ) $
fromGregorianValid y m d
2018-04-04 19:45:23 +03:00
2018-06-12 22:29:22 +03:00
ymd :: TextParser m SmartDate
2020-10-07 05:45:46 +03:00
ymd = do
y <- yearp
2022-03-14 16:02:24 +03:00
emd <- optional . try $ do
2020-10-07 05:45:46 +03:00
sep <- datesepchar
m <- decimal
unless ( validMonth m ) $ Fail . fail ( " Bad month " <> show m )
2022-03-14 16:02:24 +03:00
option ( Left m ) . try $ Right <$> do
2020-10-07 05:45:46 +03:00
_ <- char sep
d <- decimal
2022-03-14 16:02:24 +03:00
maybe ( Fail . fail $ showBadDate y m d ) return $ fromGregorianValid y m d
return $ case emd of
Nothing -> SmartAssumeStart y Nothing
Just ( Left m ) -> SmartAssumeStart y ( Just m )
Just ( Right day ) -> SmartCompleteDate day
2008-11-27 03:35:00 +03:00
2020-08-07 05:18:19 +03:00
md :: TextParser m ( Month , MonthDay )
2008-11-27 03:35:00 +03:00
md = do
2020-07-21 06:48:55 +03:00
m <- decimal
2008-11-27 03:35:00 +03:00
datesepchar
2020-07-21 06:48:55 +03:00
d <- decimal
2020-08-07 05:18:19 +03:00
_ <- failIfInvalidDate $ SmartFromReference ( Just m ) d
return ( m , d )
2020-07-21 06:48:55 +03:00
2020-07-28 16:00:25 +03:00
-- | Parse a year number from a Text, making sure that at least four digits are
-- used.
yearp :: TextParser m Integer
yearp = do
year <- takeWhile1P ( Just " year " ) isDigit
unless ( T . length year >= 4 ) . Fail . fail $ " Year must contain at least 4 digits: " <> T . unpack year
return $ readDecimal year
2008-11-27 03:35:00 +03:00
2019-07-15 13:28:52 +03:00
-- These are compared case insensitively, and should all be kept lower case.
2009-01-17 23:21:44 +03:00
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 " ]
2017-11-25 02:52:34 +03:00
weekdays = [ " monday " , " tuesday " , " wednesday " , " thursday " , " friday " , " saturday " , " sunday " ]
weekdayabbrevs = [ " mon " , " tue " , " wed " , " thu " , " fri " , " sat " , " sun " ]
2008-11-27 09:29:29 +03:00
2020-08-07 05:18:19 +03:00
month , mon :: TextParser m Month
month = choice $ zipWith ( \ i m -> i <$ string' m ) [ 1 .. 12 ] months
mon = choice $ zipWith ( \ i m -> i <$ string' m ) [ 1 .. 12 ] monthabbrevs
2008-11-27 03:35:00 +03:00
2018-06-12 22:29:22 +03:00
weekday :: TextParser m Int
2017-11-25 02:52:34 +03:00
weekday = do
2018-07-24 16:36:45 +03:00
wday <- T . toLower <$> ( choice . map string' $ weekdays ++ weekdayabbrevs )
case catMaybes $ [ wday ` elemIndex ` weekdays , wday ` elemIndex ` weekdayabbrevs ] of
( i : _ ) -> return ( i + 1 )
lib, cli, ui: start using Control.Monad.Fail, allow base-compat 0.11
fail is moving out of Monad and into it's own MonadFail class.
This will be enforced in GHC 8.8 (I think).
base-compat/base-compat-batteries 0.11.0 have adapted to this,
and are approaching stackage nightly
(https://github.com/commercialhaskell/stackage/issues/4802).
hledger is now ready to build with base-compat-batteries 0.11.0, once
all of our deps do (eg aeson). We are still compatible with the older
0.10.x and GHC 7.10.3 as well.
For now we are using both fails:
- new fail (from Control.Monad.Fail), used in our parsers, imported
via base-compat-batteries Control.Monad.Fail.Compat to work with
older GHC versions.
- old fail (from GHC.Base, exported by Prelude, Control.Monad,
Control.Monad.State.Strict, Prelude.Compat, ...), used in easytest's
Test, since I couldn't find their existing fail implementation to update.
To reduce (my) confusion, these are imported carefully, consistently,
and qualified everywhere as Fail.fail and Prelude.fail, with clashing
re-exports suppressed, like so:
import Prelude hiding (fail)
import qualified Prelude (fail)
import Control.Monad.State.Strict hiding (fail)
import "base-compat-batteries" Prelude.Compat hiding (fail)
import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail
2019-09-09 03:13:47 +03:00
[] -> Fail . fail $ " weekday: should not happen: attempted to find " <>
show wday <> " in " <> show ( weekdays ++ weekdayabbrevs )
2017-11-25 02:52:34 +03:00
2021-07-31 00:28:30 +03:00
weekdaysp :: TextParser m [ Int ]
2024-02-29 04:36:20 +03:00
weekdaysp = fmap headErr . group . sort <$> sepBy1 weekday ( string' " , " ) -- PARTIAL headErr will succeed because of sepBy1
2021-07-31 00:28:30 +03:00
2019-07-25 12:46:45 +03:00
-- | Parse a period expression, specifying a date span and optionally
-- a reporting interval. Requires a reference "today" date for
-- resolving any relative start/end dates (only; it is not needed for
-- parsing the reporting interval).
--
2020-08-26 11:11:20 +03:00
-- >>> let p = parsePeriodExpr (fromGregorian 2008 11 26)
2017-11-25 03:42:39 +03:00
-- >>> p "from Aug to Oct"
2020-03-22 15:51:18 +03:00
-- Right (NoInterval,DateSpan 2008-08-01..2008-09-30)
2016-05-07 04:05:42 +03:00
-- >>> p "aug to oct"
2020-03-22 15:51:18 +03:00
-- Right (NoInterval,DateSpan 2008-08-01..2008-09-30)
2020-07-31 17:35:27 +03:00
-- >>> p "2009q2"
-- Right (NoInterval,DateSpan 2009Q2)
-- >>> p "Q3"
-- Right (NoInterval,DateSpan 2008Q3)
2017-11-25 03:42:39 +03:00
-- >>> p "every 3 days in Aug"
2020-03-22 15:51:18 +03:00
-- Right (Days 3,DateSpan 2008-08)
2016-05-07 04:05:42 +03:00
-- >>> p "daily from aug"
2020-03-22 15:51:18 +03:00
-- Right (Days 1,DateSpan 2008-08-01..)
2016-05-07 04:05:42 +03:00
-- >>> p "every week to 2009"
2020-03-22 15:51:18 +03:00
-- Right (Weeks 1,DateSpan ..2008-12-31)
2017-11-25 01:43:53 +03:00
-- >>> p "every 2nd day of month"
2024-09-04 17:28:27 +03:00
-- Right (MonthDay 2,DateSpan ..)
2017-11-25 01:43:53 +03:00
-- >>> p "every 2nd day"
2024-09-04 17:28:27 +03:00
-- Right (MonthDay 2,DateSpan ..)
2020-06-05 04:45:03 +03:00
-- >>> p "every 2nd day 2009.."
2024-09-04 17:28:27 +03:00
-- Right (MonthDay 2,DateSpan 2009-01-01..)
2017-11-25 01:43:53 +03:00
-- >>> p "every 2nd day 2009-"
2024-09-04 17:28:27 +03:00
-- Right (MonthDay 2,DateSpan 2009-01-01..)
2017-11-25 01:43:53 +03:00
-- >>> p "every 29th Nov"
2024-09-04 17:28:27 +03:00
-- Right (MonthAndDay 11 29,DateSpan ..)
2020-06-05 04:45:03 +03:00
-- >>> p "every 29th nov ..2009"
2024-09-04 17:28:27 +03:00
-- Right (MonthAndDay 11 29,DateSpan ..2008-12-31)
2017-11-25 01:43:53 +03:00
-- >>> p "every nov 29th"
2024-09-04 17:28:27 +03:00
-- Right (MonthAndDay 11 29,DateSpan ..)
2020-06-05 04:45:03 +03:00
-- >>> p "every Nov 29th 2009.."
2024-09-04 17:28:27 +03:00
-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)
2017-11-25 01:43:53 +03:00
-- >>> p "every 11/29 from 2009"
2024-09-04 17:28:27 +03:00
-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)
2022-12-22 15:12:25 +03:00
-- >>> p "every 11/29 since 2009"
2024-09-04 17:28:27 +03:00
-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)
2017-11-25 02:52:34 +03:00
-- >>> p "every 2nd Thursday of month to 2009"
2024-09-04 17:28:27 +03:00
-- Right (NthWeekdayOfMonth 2 4,DateSpan ..2008-12-31)
2017-11-25 02:52:34 +03:00
-- >>> p "every 1st monday of month to 2009"
2024-09-04 17:28:27 +03:00
-- Right (NthWeekdayOfMonth 1 1,DateSpan ..2008-12-31)
2017-11-25 02:02:55 +03:00
-- >>> p "every tue"
2021-07-31 00:28:30 +03:00
-- Right (DaysOfWeek [2],DateSpan ..)
2017-11-25 02:02:55 +03:00
-- >>> p "every 2nd day of week"
2021-07-31 00:28:30 +03:00
-- Right (DaysOfWeek [2],DateSpan ..)
2017-11-26 06:58:53 +03:00
-- >>> p "every 2nd day of month"
2024-09-04 17:28:27 +03:00
-- Right (MonthDay 2,DateSpan ..)
2017-11-26 06:58:53 +03:00
-- >>> p "every 2nd day"
2024-09-04 17:28:27 +03:00
-- Right (MonthDay 2,DateSpan ..)
2020-06-05 04:45:03 +03:00
-- >>> p "every 2nd day 2009.."
2024-09-04 17:28:27 +03:00
-- Right (MonthDay 2,DateSpan 2009-01-01..)
2020-06-05 04:45:03 +03:00
-- >>> p "every 2nd day of month 2009.."
2024-09-04 17:28:27 +03:00
-- Right (MonthDay 2,DateSpan 2009-01-01..)
2018-06-12 22:29:22 +03:00
periodexprp :: Day -> TextParser m ( Interval , DateSpan )
2018-06-13 02:39:17 +03:00
periodexprp rdate = do
2020-07-20 18:09:46 +03:00
skipNonNewlineSpaces
2020-08-07 05:18:19 +03:00
choice' [ intervalanddateperiodexprp rdate
, ( , ) NoInterval <$> periodexprdatespanp rdate
]
2008-11-27 22:42:03 +03:00
2019-07-25 12:46:45 +03:00
-- Parse a reporting interval and a date span.
2018-06-12 22:29:22 +03:00
intervalanddateperiodexprp :: Day -> TextParser m ( Interval , DateSpan )
2018-06-09 05:35:27 +03:00
intervalanddateperiodexprp rdate = do
i <- reportingintervalp
2017-11-26 06:58:53 +03:00
s <- option def . try $ do
2020-07-20 18:09:46 +03:00
skipNonNewlineSpaces
2018-06-09 05:35:27 +03:00
periodexprdatespanp rdate
2008-12-04 02:20:38 +03:00
return ( i , s )
2011-01-14 07:32:08 +03:00
-- Parse a reporting interval.
2018-06-12 22:29:22 +03:00
reportingintervalp :: TextParser m Interval
2020-07-21 06:48:55 +03:00
reportingintervalp = choice'
[ tryinterval " day " " daily " Days
, tryinterval " month " " monthly " Months
, tryinterval " quarter " " quarterly " Quarters
, tryinterval " year " " yearly " Years
, Weeks 2 <$ string' " biweekly "
, Weeks 2 <$ string' " fortnightly "
, Months 2 <$ string' " bimonthly "
, string' " every " *> skipNonNewlineSpaces *> choice'
2021-07-31 00:28:30 +03:00
[ DaysOfWeek . pure <$> ( nth <* skipNonNewlineSpaces <* string' " day " <* of_ " week " )
2024-09-04 17:28:27 +03:00
, MonthDay <$> ( nth <* skipNonNewlineSpaces <* string' " day " <* optOf_ " month " )
, liftA2 NthWeekdayOfMonth nth $ skipNonNewlineSpaces *> weekday <* optOf_ " month "
, uncurry MonthAndDay <$> ( md <* optOf_ " year " )
2021-07-31 00:28:30 +03:00
, DaysOfWeek <$> weekdaysp
, DaysOfWeek [ 1 .. 5 ] <$ string' " weekday "
, DaysOfWeek [ 6 .. 7 ] <$ string' " weekendday "
2020-07-21 06:48:55 +03:00
, d_o_y <* optOf_ " year "
]
2021-07-31 00:28:30 +03:00
-- NB: the ordering is important here since the parse for `every weekday`
-- would match the `tryinterval` first and then error on `d`. Perhaps it
-- would be clearer to factor some of this into the `every` choice or other
-- left-factorings.
, tryinterval " week " " weekly " Weeks
2020-07-21 06:48:55 +03:00
]
where
of_ period =
skipNonNewlineSpaces *> string' " of " *> skipNonNewlineSpaces *> string' period
optOf_ period = optional . try $ of_ period
nth = decimal <* choice ( map string' [ " st " , " nd " , " rd " , " th " ] )
2024-09-04 17:28:27 +03:00
d_o_y = runPermutation $ liftA2 MonthAndDay ( toPermutation $ ( month <|> mon ) <* skipNonNewlineSpaces )
( toPermutation $ nth <* skipNonNewlineSpaces )
2020-07-21 06:48:55 +03:00
-- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".
2022-01-04 14:02:07 +03:00
tryinterval :: Text -> Text -> ( Int -> Interval ) -> TextParser m Interval
2020-07-21 06:48:55 +03:00
tryinterval singular compact intcons = intcons <$> choice'
2022-01-04 14:02:07 +03:00
[ 1 <$ string' compact
2020-07-21 06:48:55 +03:00
, string' " every " *> skipNonNewlineSpaces *> choice
2022-01-04 14:02:07 +03:00
[ 1 <$ string' singular
, decimal <* skipNonNewlineSpaces <* string' ( singular <> " s " )
2020-07-21 06:48:55 +03:00
]
]
2017-07-27 14:59:55 +03:00
2018-06-12 22:29:22 +03:00
periodexprdatespanp :: Day -> TextParser m DateSpan
2018-06-09 05:35:27 +03:00
periodexprdatespanp rdate = choice $ map try [
doubledatespanp rdate ,
2020-07-31 17:35:27 +03:00
quarterdatespanp rdate ,
2018-06-09 05:35:27 +03:00
fromdatespanp rdate ,
todatespanp rdate ,
justdatespanp rdate
2008-12-04 02:20:38 +03:00
]
2018-04-04 19:45:23 +03:00
-- |
2020-08-26 11:11:20 +03:00
-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "20180101-201804"
2020-07-31 17:26:33 +03:00
-- Right DateSpan 2018Q1
2020-10-07 05:45:46 +03:00
-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017..2018"
-- Right DateSpan 2017
-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017-2018"
-- Right DateSpan 2017
-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017-01-2018"
-- Right DateSpan 2017
-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017-01-01-2018"
-- Right DateSpan 2017
2018-06-12 22:29:22 +03:00
doubledatespanp :: Day -> TextParser m DateSpan
2020-07-21 05:42:28 +03:00
doubledatespanp rdate = liftA2 fromToSpan
2022-12-22 15:12:25 +03:00
( optional ( ( string' " from " <|> string' " since " ) *> skipNonNewlineSpaces ) *> smartdate )
2020-07-21 05:42:28 +03:00
( skipNonNewlineSpaces *> choice [ string' " to " , string " .. " , string " - " ]
*> skipNonNewlineSpaces *> smartdate )
where
fromToSpan = DateSpan ` on ` ( Just . fixSmartDate rdate )
2008-11-27 22:42:03 +03:00
2020-07-31 17:35:27 +03:00
-- |
2020-08-26 11:11:20 +03:00
-- >>> parsewith (quarterdatespanp (fromGregorian 2018 01 01) <* eof) "q1"
2020-07-31 17:35:27 +03:00
-- Right DateSpan 2018Q1
2020-08-26 11:11:20 +03:00
-- >>> parsewith (quarterdatespanp (fromGregorian 2018 01 01) <* eof) "Q1"
2020-08-03 09:01:12 +03:00
-- Right DateSpan 2018Q1
2020-08-26 11:11:20 +03:00
-- >>> parsewith (quarterdatespanp (fromGregorian 2018 01 01) <* eof) "2020q4"
2020-07-31 17:35:27 +03:00
-- Right DateSpan 2020Q4
quarterdatespanp :: Day -> TextParser m DateSpan
quarterdatespanp rdate = do
2020-08-03 09:01:12 +03:00
y <- yearp <|> pure ( first3 $ toGregorian rdate )
q <- char' 'q' *> satisfy is4Digit
return . periodAsDateSpan $ QuarterPeriod y ( digitToInt q )
where
is4Digit c = ( fromIntegral ( ord c - ord '1' ) :: Word ) <= 3
2020-07-31 17:35:27 +03:00
2018-06-12 22:29:22 +03:00
fromdatespanp :: Day -> TextParser m DateSpan
2020-07-21 05:42:28 +03:00
fromdatespanp rdate = fromSpan <$> choice
2022-12-22 15:12:25 +03:00
[ ( string' " from " <|> string' " since " ) *> skipNonNewlineSpaces *> smartdate
2020-07-21 05:42:28 +03:00
, smartdate <* choice [ string " .. " , string " - " ]
2013-09-27 02:06:48 +04:00
]
2020-07-21 05:42:28 +03:00
where
fromSpan b = DateSpan ( Just $ fixSmartDate rdate b ) Nothing
2008-12-04 02:20:38 +03:00
2018-06-12 22:29:22 +03:00
todatespanp :: Day -> TextParser m DateSpan
2020-07-21 05:42:28 +03:00
todatespanp rdate =
choice [ string' " to " , string' " until " , string " .. " , string " - " ]
*> skipNonNewlineSpaces
*> ( DateSpan Nothing . Just . fixSmartDate rdate <$> smartdate )
2008-11-27 22:42:03 +03:00
2018-06-12 22:29:22 +03:00
justdatespanp :: Day -> TextParser m DateSpan
2020-07-21 05:42:28 +03:00
justdatespanp rdate =
optional ( string' " in " *> skipNonNewlineSpaces )
*> ( spanFromSmartDate rdate <$> smartdate )
2008-12-04 22:29:29 +03:00
2011-06-14 23:10:16 +04:00
nulldatespan :: DateSpan
2008-12-04 22:29:29 +03:00
nulldatespan = DateSpan Nothing Nothing
2023-01-19 12:02:09 +03:00
-- | An exact datespan of zero length, that matches no date.
2018-10-17 23:10:49 +03:00
emptydatespan :: DateSpan
2023-01-19 12:02:09 +03:00
emptydatespan = DateSpan ( Just $ Exact $ addDays 1 nulldate ) ( Just $ Exact nulldate )
2018-10-17 23:10:49 +03:00
2011-06-14 23:10:16 +04:00
nulldate :: Day
2016-05-27 18:06:53 +03:00
nulldate = fromGregorian 0 1 1
2021-07-31 00:28:30 +03:00
-- tests
2021-08-30 08:23:23 +03:00
tests_Dates = testGroup " Dates "
[ testCase " weekday " $ do
2023-01-19 12:02:09 +03:00
splitSpan False ( DaysOfWeek [ 1 .. 5 ] ) ( DateSpan ( Just $ Exact $ fromGregorian 2021 07 01 ) ( Just $ Exact $ fromGregorian 2021 07 08 ) )
@?= [ ( DateSpan ( Just $ Exact $ fromGregorian 2021 06 28 ) ( Just $ Exact $ fromGregorian 2021 06 29 ) )
, ( DateSpan ( Just $ Exact $ fromGregorian 2021 06 29 ) ( Just $ Exact $ fromGregorian 2021 06 30 ) )
, ( DateSpan ( Just $ Exact $ fromGregorian 2021 06 30 ) ( Just $ Exact $ fromGregorian 2021 07 01 ) )
, ( DateSpan ( Just $ Exact $ fromGregorian 2021 07 01 ) ( Just $ Exact $ fromGregorian 2021 07 02 ) )
, ( DateSpan ( Just $ Exact $ fromGregorian 2021 07 02 ) ( Just $ Exact $ fromGregorian 2021 07 05 ) )
2021-07-31 00:28:30 +03:00
-- next week
2023-01-19 12:02:09 +03:00
, ( DateSpan ( Just $ Exact $ fromGregorian 2021 07 05 ) ( Just $ Exact $ fromGregorian 2021 07 06 ) )
, ( DateSpan ( Just $ Exact $ fromGregorian 2021 07 06 ) ( Just $ Exact $ fromGregorian 2021 07 07 ) )
, ( DateSpan ( Just $ Exact $ fromGregorian 2021 07 07 ) ( Just $ Exact $ fromGregorian 2021 07 08 ) )
2021-07-31 00:28:30 +03:00
]
2023-01-19 12:02:09 +03:00
splitSpan False ( DaysOfWeek [ 1 , 5 ] ) ( DateSpan ( Just $ Exact $ fromGregorian 2021 07 01 ) ( Just $ Exact $ fromGregorian 2021 07 08 ) )
@?= [ ( DateSpan ( Just $ Exact $ fromGregorian 2021 06 28 ) ( Just $ Exact $ fromGregorian 2021 07 02 ) )
, ( DateSpan ( Just $ Exact $ fromGregorian 2021 07 02 ) ( Just $ Exact $ fromGregorian 2021 07 05 ) )
2021-07-31 00:28:30 +03:00
-- next week
2023-01-19 12:02:09 +03:00
, ( DateSpan ( Just $ Exact $ fromGregorian 2021 07 05 ) ( Just $ Exact $ fromGregorian 2021 07 09 ) )
2021-07-31 00:28:30 +03:00
]
2021-08-30 08:23:23 +03:00
, testCase " match dayOfWeek " $ do
2022-08-23 13:58:31 +03:00
let dayofweek n = splitspan ( nthdayofweekcontaining n ) ( \ w -> ( if w == 0 then id else applyN ( n - 1 ) nextday . applyN ( fromInteger w ) nextweek ) ) 1
2023-01-13 05:19:52 +03:00
matchdow ds day = splitSpan False ( DaysOfWeek [ day ] ) ds @?= dayofweek day ds
2021-07-31 00:28:30 +03:00
ys2021 = fromGregorian 2021 01 01
ye2021 = fromGregorian 2021 12 31
ys2022 = fromGregorian 2022 01 01
2023-01-19 12:02:09 +03:00
mapM_ ( matchdow ( DateSpan ( Just $ Exact ys2021 ) ( Just $ Exact ye2021 ) ) ) [ 1 .. 7 ]
mapM_ ( matchdow ( DateSpan ( Just $ Exact ys2021 ) ( Just $ Exact ys2022 ) ) ) [ 1 .. 7 ]
mapM_ ( matchdow ( DateSpan ( Just $ Exact ye2021 ) ( Just $ Exact ys2022 ) ) ) [ 1 .. 7 ]
2021-07-31 00:28:30 +03:00
2023-01-19 12:02:09 +03:00
mapM_ ( matchdow ( DateSpan ( Just $ Exact ye2021 ) Nothing ) ) [ 1 .. 7 ]
mapM_ ( matchdow ( DateSpan ( Just $ Exact ys2022 ) Nothing ) ) [ 1 .. 7 ]
2021-07-31 00:28:30 +03:00
2023-01-19 12:02:09 +03:00
mapM_ ( matchdow ( DateSpan Nothing ( Just $ Exact ye2021 ) ) ) [ 1 .. 7 ]
mapM_ ( matchdow ( DateSpan Nothing ( Just $ Exact ys2022 ) ) ) [ 1 .. 7 ]
2021-07-31 00:28:30 +03:00
]