module Hledger.Data.DayPartition
( DayPartition
, boundariesToDayPartition
, boundariesToMaybeDayPartition
, dayPartitionToNonEmpty
, dayPartitionToList
, dayPartitionToDateSpans
, dayPartitionToPeriodData
, maybeDayPartitionToDateSpans
, unionDayPartitions
, dayPartitionStartEnd
, dayPartitionFind
, splitSpan
, intervalBoundaryBefore
, tests_DayPartition
) where
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Map qualified as M
import Data.Time (Day (..), addDays, addGregorianMonthsClip, addGregorianYearsClip, fromGregorian)
import Hledger.Data.Dates
import Hledger.Data.PeriodData
import Hledger.Data.Types
import Hledger.Utils
newtype DayPartition = DayPartition { DayPartition -> PeriodData Day
dayPartitionToPeriodData :: PeriodData Day } deriving (DayPartition -> DayPartition -> Bool
(DayPartition -> DayPartition -> Bool)
-> (DayPartition -> DayPartition -> Bool) -> Eq DayPartition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DayPartition -> DayPartition -> Bool
== :: DayPartition -> DayPartition -> Bool
$c/= :: DayPartition -> DayPartition -> Bool
/= :: DayPartition -> DayPartition -> Bool
Eq, Eq DayPartition
Eq DayPartition =>
(DayPartition -> DayPartition -> Ordering)
-> (DayPartition -> DayPartition -> Bool)
-> (DayPartition -> DayPartition -> Bool)
-> (DayPartition -> DayPartition -> Bool)
-> (DayPartition -> DayPartition -> Bool)
-> (DayPartition -> DayPartition -> DayPartition)
-> (DayPartition -> DayPartition -> DayPartition)
-> Ord DayPartition
DayPartition -> DayPartition -> Bool
DayPartition -> DayPartition -> Ordering
DayPartition -> DayPartition -> DayPartition
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DayPartition -> DayPartition -> Ordering
compare :: DayPartition -> DayPartition -> Ordering
$c< :: DayPartition -> DayPartition -> Bool
< :: DayPartition -> DayPartition -> Bool
$c<= :: DayPartition -> DayPartition -> Bool
<= :: DayPartition -> DayPartition -> Bool
$c> :: DayPartition -> DayPartition -> Bool
> :: DayPartition -> DayPartition -> Bool
$c>= :: DayPartition -> DayPartition -> Bool
>= :: DayPartition -> DayPartition -> Bool
$cmax :: DayPartition -> DayPartition -> DayPartition
max :: DayPartition -> DayPartition -> DayPartition
$cmin :: DayPartition -> DayPartition -> DayPartition
min :: DayPartition -> DayPartition -> DayPartition
Ord, Int -> DayPartition -> ShowS
[DayPartition] -> ShowS
DayPartition -> String
(Int -> DayPartition -> ShowS)
-> (DayPartition -> String)
-> ([DayPartition] -> ShowS)
-> Show DayPartition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DayPartition -> ShowS
showsPrec :: Int -> DayPartition -> ShowS
$cshow :: DayPartition -> String
show :: DayPartition -> String
$cshowList :: [DayPartition] -> ShowS
showList :: [DayPartition] -> ShowS
Show)
boundariesToDayPartition :: NonEmpty Day -> DayPartition
boundariesToDayPartition :: NonEmpty Day -> DayPartition
boundariesToDayPartition NonEmpty Day
xs = PeriodData Day -> DayPartition
DayPartition (PeriodData Day -> DayPartition)
-> ([(Day, Day)] -> PeriodData Day) -> [(Day, Day)] -> DayPartition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> [(Day, Day)] -> PeriodData Day
forall a. a -> [(Day, a)] -> PeriodData a
periodDataFromList (Integer -> Day -> Day
addDays (-Integer
1) Day
b) ([(Day, Day)] -> DayPartition) -> [(Day, Day)] -> DayPartition
forall a b. (a -> b) -> a -> b
$ case [Day]
bs of
[] -> [(Day
b, Day
b)]
Day
_:[Day]
_ -> [Day] -> [Day] -> [(Day, Day)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Day
bDay -> [Day] -> [Day]
forall a. a -> [a] -> [a]
:[Day]
bs) ([Day] -> [(Day, Day)]) -> [Day] -> [(Day, Day)]
forall a b. (a -> b) -> a -> b
$ (Day -> Day) -> [Day] -> [Day]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Day -> Day
addDays (-Integer
1)) [Day]
bs
where Day
b:|[Day]
bs = NonEmpty Day -> NonEmpty Day
forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub (NonEmpty Day -> NonEmpty Day) -> NonEmpty Day -> NonEmpty Day
forall a b. (a -> b) -> a -> b
$ NonEmpty Day -> NonEmpty Day
forall a. Ord a => NonEmpty a -> NonEmpty a
NE.sort NonEmpty Day
xs
boundariesToMaybeDayPartition :: [Day] -> Maybe DayPartition
boundariesToMaybeDayPartition :: [Day] -> Maybe DayPartition
boundariesToMaybeDayPartition = (NonEmpty Day -> DayPartition)
-> Maybe (NonEmpty Day) -> Maybe DayPartition
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Day -> DayPartition
boundariesToDayPartition (Maybe (NonEmpty Day) -> Maybe DayPartition)
-> ([Day] -> Maybe (NonEmpty Day)) -> [Day] -> Maybe DayPartition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Day] -> Maybe (NonEmpty Day)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
dayPartitionToNonEmpty :: DayPartition -> NonEmpty (Day, Day)
dayPartitionToNonEmpty :: DayPartition -> NonEmpty (Day, Day)
dayPartitionToNonEmpty (DayPartition PeriodData Day
xs) = [(Day, Day)] -> NonEmpty (Day, Day)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([(Day, Day)] -> NonEmpty (Day, Day))
-> ((Day, [(Day, Day)]) -> [(Day, Day)])
-> (Day, [(Day, Day)])
-> NonEmpty (Day, Day)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Day, [(Day, Day)]) -> [(Day, Day)]
forall a b. (a, b) -> b
snd ((Day, [(Day, Day)]) -> NonEmpty (Day, Day))
-> (Day, [(Day, Day)]) -> NonEmpty (Day, Day)
forall a b. (a -> b) -> a -> b
$ PeriodData Day -> (Day, [(Day, Day)])
forall a. PeriodData a -> (a, [(Day, a)])
periodDataToList PeriodData Day
xs
dayPartitionToList :: DayPartition -> [(Day, Day)]
dayPartitionToList :: DayPartition -> [(Day, Day)]
dayPartitionToList = NonEmpty (Day, Day) -> [(Day, Day)]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (Day, Day) -> [(Day, Day)])
-> (DayPartition -> NonEmpty (Day, Day))
-> DayPartition
-> [(Day, Day)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DayPartition -> NonEmpty (Day, Day)
dayPartitionToNonEmpty
dayPartitionToDateSpans :: DayPartition -> [DateSpan]
dayPartitionToDateSpans :: DayPartition -> [DateSpan]
dayPartitionToDateSpans = ((Day, Day) -> DateSpan) -> [(Day, Day)] -> [DateSpan]
forall a b. (a -> b) -> [a] -> [b]
map (Day, Day) -> DateSpan
toDateSpan ([(Day, Day)] -> [DateSpan])
-> (DayPartition -> [(Day, Day)]) -> DayPartition -> [DateSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DayPartition -> [(Day, Day)]
dayPartitionToList
where
toDateSpan :: (Day, Day) -> DateSpan
toDateSpan (Day
s, Day
e) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (Day -> Maybe EFDay
toEFDay Day
s) (Day -> Maybe EFDay
toEFDay (Day -> Maybe EFDay) -> Day -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
e)
toEFDay :: Day -> Maybe EFDay
toEFDay = EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> (Day -> EFDay) -> Day -> Maybe EFDay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> EFDay
Exact
maybeDayPartitionToDateSpans :: Maybe DayPartition -> [DateSpan]
maybeDayPartitionToDateSpans :: Maybe DayPartition -> [DateSpan]
maybeDayPartitionToDateSpans = [DateSpan]
-> (DayPartition -> [DateSpan]) -> Maybe DayPartition -> [DateSpan]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan Maybe EFDay
forall a. Maybe a
Nothing Maybe EFDay
forall a. Maybe a
Nothing] DayPartition -> [DateSpan]
dayPartitionToDateSpans
isValidDayPartition :: DayPartition -> Bool
isValidDayPartition :: DayPartition -> Bool
isValidDayPartition (DayPartition PeriodData Day
pd) = case [(Day, Day)]
ds of
[] -> Bool
False
[(Day, Day)]
xs -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ ((Day, Day) -> (Day, Day) -> Bool)
-> [(Day, Day)] -> [(Day, Day)] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Day, Day) -> (Day, Day) -> Bool
forall {a} {b}. (a, Day) -> (Day, b) -> Bool
isContiguous ((Day
nulldate, Day
h) (Day, Day) -> [(Day, Day)] -> [(Day, Day)]
forall a. a -> [a] -> [a]
: [(Day, Day)]
xs) [(Day, Day)]
xs
where
(Day
h, [(Day, Day)]
ds) = PeriodData Day -> (Day, [(Day, Day)])
forall a. PeriodData a -> (a, [(Day, a)])
periodDataToList PeriodData Day
pd
isContiguous :: (a, Day) -> (Day, b) -> Bool
isContiguous (a
_, Day
e) (Day
s, b
_) = Integer -> Day -> Day
addDays Integer
1 Day
e Day -> Day -> Bool
forall a. Eq a => a -> a -> Bool
== Day
s
unionDayPartitions :: DayPartition -> DayPartition -> Maybe DayPartition
unionDayPartitions :: DayPartition -> DayPartition -> Maybe DayPartition
unionDayPartitions (DayPartition (PeriodData Day
h Map Day Day
as)) (DayPartition (PeriodData Day
h' Map Day Day
as')) =
if Map Day Day -> Map Day Day -> Bool
forall {k} {b}. (Ord k, Eq b) => Map k b -> Map k b -> Bool
equalIntersection Map Day Day
as Map Day Day
as' Bool -> Bool -> Bool
&& DayPartition -> Bool
isValidDayPartition DayPartition
union then DayPartition -> Maybe DayPartition
forall a. a -> Maybe a
Just DayPartition
union else Maybe DayPartition
forall a. Maybe a
Nothing
where
union :: DayPartition
union = PeriodData Day -> DayPartition
DayPartition (PeriodData Day -> DayPartition)
-> (Map Day Day -> PeriodData Day) -> Map Day Day -> DayPartition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Map Day Day -> PeriodData Day
forall a. a -> Map Day a -> PeriodData a
PeriodData (Day -> Day -> Day
forall a. Ord a => a -> a -> a
min Day
h Day
h') (Map Day Day -> DayPartition) -> Map Day Day -> DayPartition
forall a b. (a -> b) -> a -> b
$ Map Day Day
as Map Day Day -> Map Day Day -> Map Day Day
forall a. Semigroup a => a -> a -> a
<> Map Day Day
as'
equalIntersection :: Map k b -> Map k b -> Bool
equalIntersection Map k b
x Map k b
y = Map k Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (Map k Bool -> Bool) -> Map k Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (b -> b -> Bool) -> Map k b -> Map k b -> Map k Bool
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith b -> b -> Bool
forall a. Eq a => a -> a -> Bool
(==) Map k b
x Map k b
y
dayPartitionStartEnd :: DayPartition -> (Day, Day)
dayPartitionStartEnd :: DayPartition -> (Day, Day)
dayPartitionStartEnd (DayPartition (PeriodData Day
_ Map Day Day
ds)) =
((Day, Day) -> Day
forall a b. (a, b) -> a
fst ((Day, Day) -> Day) -> (Day, Day) -> Day
forall a b. (a -> b) -> a -> b
$ Map Day Day -> (Day, Day)
forall k a. Map k a -> (k, a)
M.findMin Map Day Day
ds, (Day, Day) -> Day
forall a b. (a, b) -> b
snd ((Day, Day) -> Day) -> (Day, Day) -> Day
forall a b. (a -> b) -> a -> b
$ Map Day Day -> (Day, Day)
forall k a. Map k a -> (k, a)
M.findMax Map Day Day
ds)
dayPartitionFind :: Day -> DayPartition -> (Maybe Day, Day)
dayPartitionFind :: Day -> DayPartition -> (Maybe Day, Day)
dayPartitionFind Day
d (DayPartition PeriodData Day
xs) = Day -> PeriodData Day -> (Maybe Day, Day)
forall a. Day -> PeriodData a -> (Maybe Day, a)
lookupPeriodDataOrHistorical Day
d PeriodData Day
xs
splitSpan :: Bool -> Interval -> DateSpan -> Maybe DayPartition
splitSpan :: Bool -> Interval -> DateSpan -> Maybe DayPartition
splitSpan Bool
_ Interval
_ (DateSpan Maybe EFDay
Nothing Maybe EFDay
Nothing) = Maybe DayPartition
forall a. Maybe a
Nothing
splitSpan Bool
_ Interval
_ DateSpan
ds | DateSpan -> Bool
isEmptySpan DateSpan
ds = Maybe DayPartition
forall a. Maybe a
Nothing
splitSpan Bool
_ Interval
NoInterval (DateSpan (Just EFDay
s) (Just EFDay
e)) = DayPartition -> Maybe DayPartition
forall a. a -> Maybe a
Just (DayPartition -> Maybe DayPartition)
-> DayPartition -> Maybe DayPartition
forall a b. (a -> b) -> a -> b
$ NonEmpty Day -> DayPartition
boundariesToDayPartition (EFDay -> Day
fromEFDay EFDay
s Day -> [Day] -> NonEmpty Day
forall a. a -> [a] -> NonEmpty a
:| [EFDay -> Day
fromEFDay EFDay
e])
splitSpan Bool
_ Interval
NoInterval DateSpan
_ = Maybe DayPartition
forall a. Maybe a
Nothing
splitSpan Bool
_ (Days Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition
splitspan Day -> Day
forall a. a -> a
id Integer -> Day -> Day
addDays Int
n DateSpan
ds
splitSpan Bool
adjust (Weeks Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition
splitspan (if Bool
adjust then Day -> Day
startofweek else Day -> Day
forall a. a -> a
id) Integer -> Day -> Day
addDays (Int
7Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n) DateSpan
ds
splitSpan Bool
adjust (Months Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition
splitspan (if Bool
adjust then Day -> Day
startofmonth else Day -> Day
forall a. a -> a
id) Integer -> Day -> Day
addGregorianMonthsClip Int
n DateSpan
ds
splitSpan Bool
adjust (Quarters Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition
splitspan (if Bool
adjust then Day -> Day
startofquarter else Day -> Day
forall a. a -> a
id) Integer -> Day -> Day
addGregorianMonthsClip (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n) DateSpan
ds
splitSpan Bool
adjust (Years Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition
splitspan (if Bool
adjust then Day -> Day
startofyear else Day -> Day
forall a. a -> a
id) Integer -> Day -> Day
addGregorianYearsClip Int
n DateSpan
ds
splitSpan Bool
adjust (NthWeekdayOfMonth Int
n Int
wd) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition
splitspan (Int -> Int -> Day -> Day
startWeekdayOfMonth Int
n Int
wd) Integer -> Day -> Day
advancemonths Int
1 DateSpan
ds
where
startWeekdayOfMonth :: Int -> Int -> Day -> Day
startWeekdayOfMonth = if Bool
adjust then Int -> Int -> Day -> Day
prevNthWeekdayOfMonth else Int -> Int -> Day -> Day
nextNthWeekdayOfMonth
advancemonths :: Integer -> Day -> Day
advancemonths Integer
0 = Day -> Day
forall a. a -> a
id
advancemonths Integer
m = Int -> Int -> Day -> Day
advanceToNthWeekday Int
n Int
wd (Day -> Day) -> (Day -> Day) -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Day
startofmonth (Day -> Day) -> (Day -> Day) -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianMonthsClip Integer
m
splitSpan Bool
_ (MonthDay Int
dom) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition
splitspan (Int -> Day -> Day
nextnthdayofmonth Int
dom) (Int -> Integer -> Day -> Day
addGregorianMonthsToMonthday Int
dom) Int
1 DateSpan
ds
splitSpan Bool
_ (MonthAndDay Int
m Int
d) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition
splitspan (Int -> Int -> Day -> Day
nextmonthandday Int
m Int
d) Integer -> Day -> Day
addGregorianYearsClip Int
1 DateSpan
ds
splitSpan Bool
_ (DaysOfWeek []) DateSpan
_ = Maybe DayPartition
forall a. Maybe a
Nothing
splitSpan Bool
_ (DaysOfWeek days :: [Int]
days@(Int
n:[Int]
_)) DateSpan
ds = do
(Day
s, Day
e) <- (Day -> Day) -> (Day -> Day) -> DateSpan -> Maybe (Day, Day)
dateSpanSplitLimits (Int -> Day -> Day
nthdayofweekcontaining Int
n) Day -> Day
nextday DateSpan
ds
let
bdrys :: [Day]
bdrys = (Integer -> [Day]) -> [Integer] -> [Day]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Integer
d -> (Day -> Day) -> [Day] -> [Day]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Day -> Day
addDays Integer
d) [Day]
starts) [Integer
0,Integer
7..]
starts :: [Day]
starts = (Int -> Day) -> [Int] -> [Day]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
d -> Integer -> Day -> Day
addDays (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Int -> Day -> Day
nthdayofweekcontaining Int
n Day
s) [Int]
days
Day -> [Day] -> Maybe DayPartition
spansFromBoundaries Day
e [Day]
bdrys
dateSpanSplitLimits :: (Day -> Day) -> (Day -> Day) -> DateSpan -> Maybe (Day, Day)
dateSpanSplitLimits :: (Day -> Day) -> (Day -> Day) -> DateSpan -> Maybe (Day, Day)
dateSpanSplitLimits Day -> Day
_ Day -> Day
_ (DateSpan Maybe EFDay
Nothing Maybe EFDay
Nothing) = Maybe (Day, Day)
forall a. Maybe a
Nothing
dateSpanSplitLimits Day -> Day
_ Day -> Day
_ DateSpan
ds | DateSpan -> Bool
isEmptySpan DateSpan
ds = Maybe (Day, Day)
forall a. Maybe a
Nothing
dateSpanSplitLimits Day -> Day
start Day -> Day
_ (DateSpan (Just EFDay
s) (Just EFDay
e)) = (Day, Day) -> Maybe (Day, Day)
forall a. a -> Maybe a
Just (Day -> Day
start (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
s, EFDay -> Day
fromEFDay EFDay
e)
dateSpanSplitLimits Day -> Day
start Day -> Day
next (DateSpan (Just EFDay
s) Maybe EFDay
Nothing) = (Day, Day) -> Maybe (Day, Day)
forall a. a -> Maybe a
Just (Day -> Day
start (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
s, Day -> Day
next (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
start (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
s)
dateSpanSplitLimits Day -> Day
start Day -> Day
next (DateSpan Maybe EFDay
Nothing (Just EFDay
e)) = (Day, Day) -> Maybe (Day, Day)
forall a. a -> Maybe a
Just (Day -> Day
start (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
e, Day -> Day
next (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
start (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
e)
splitspan :: (Day -> Day) -> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition
splitspan :: (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition
splitspan Day -> Day
start Integer -> Day -> Day
next Int
mult DateSpan
ds = do
(Day
s, Day
e) <- (Day -> Day) -> (Day -> Day) -> DateSpan -> Maybe (Day, Day)
dateSpanSplitLimits Day -> Day
start (Integer -> Day -> Day
next (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
mult)) DateSpan
ds
let bdrys :: [Day]
bdrys = (Int -> Day -> Day) -> [Int] -> Day -> [Day]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Integer -> Day -> Day
next (Integer -> Day -> Day) -> (Int -> Integer) -> Int -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger) [Int
0,Int
mult..] (Day -> [Day]) -> Day -> [Day]
forall a b. (a -> b) -> a -> b
$ Day -> Day
start Day
s
Day -> [Day] -> Maybe DayPartition
spansFromBoundaries Day
e [Day]
bdrys
spansFromBoundaries :: Day -> [Day] -> Maybe DayPartition
spansFromBoundaries :: Day -> [Day] -> Maybe DayPartition
spansFromBoundaries Day
_ [] = Maybe DayPartition
forall a. Maybe a
Nothing
spansFromBoundaries Day
e (Day
x:[Day]
_) | Day
x Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= Day
e = Maybe DayPartition
forall a. Maybe a
Nothing
spansFromBoundaries Day
e (Day
x:[Day]
xs) = DayPartition -> Maybe DayPartition
forall a. a -> Maybe a
Just (DayPartition -> Maybe DayPartition)
-> (NonEmpty Day -> DayPartition)
-> NonEmpty Day
-> Maybe DayPartition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Day -> DayPartition
boundariesToDayPartition (NonEmpty Day -> Maybe DayPartition)
-> NonEmpty Day -> Maybe DayPartition
forall a b. (a -> b) -> a -> b
$ (Day -> Bool) -> NonEmpty Day -> NonEmpty Day
forall a. (a -> Bool) -> NonEmpty a -> NonEmpty a
takeUntilFailsNE (Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<Day
e) (Day
xDay -> [Day] -> NonEmpty Day
forall a. a -> [a] -> NonEmpty a
:|[Day]
xs)
intervalBoundaryBefore :: Interval -> Day -> Day
intervalBoundaryBefore :: Interval -> Day -> Day
intervalBoundaryBefore Interval
i Day
d =
case DayPartition -> NonEmpty (Day, Day)
dayPartitionToNonEmpty (DayPartition -> NonEmpty (Day, Day))
-> Maybe DayPartition -> Maybe (NonEmpty (Day, Day))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Interval -> DateSpan -> Maybe DayPartition
splitSpan Bool
True Interval
i (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
d) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> (Day -> EFDay) -> Day -> Maybe EFDay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> EFDay
Exact (Day -> Maybe EFDay) -> Day -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
d)) of
Just ((Day
start, Day
_) :| [(Day, Day)]
_ ) -> Day
start
Maybe (NonEmpty (Day, Day))
_ -> Day
d
tests_DayPartition :: TestTree
tests_DayPartition =
String -> [TestTree] -> TestTree
testGroup String
"splitSpan" [
String -> Assertion -> TestTree
testCase String
"weekday" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
(DayPartition -> NonEmpty (Day, Day))
-> Maybe DayPartition -> Maybe (NonEmpty (Day, Day))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DayPartition -> NonEmpty (Day, Day)
dayPartitionToNonEmpty (Bool -> Interval -> DateSpan -> Maybe DayPartition
splitSpan Bool
False ([Int] -> Interval
DaysOfWeek [Int
1..Int
5]) (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
08)))
Maybe (NonEmpty (Day, Day))
-> Maybe (NonEmpty (Day, Day)) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= NonEmpty (Day, Day) -> Maybe (NonEmpty (Day, Day))
forall a. a -> Maybe a
Just ( (Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
28, Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
28) (Day, Day) -> [(Day, Day)] -> NonEmpty (Day, Day)
forall a. a -> [a] -> NonEmpty a
:|
[ (Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
29, Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
29)
, (Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
30, Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
30)
, (Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01, Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01)
, (Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02, Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
04)
, (Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05, Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05)
, (Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
06, Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
06)
, (Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
07, Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
07)
])
(DayPartition -> NonEmpty (Day, Day))
-> Maybe DayPartition -> Maybe (NonEmpty (Day, Day))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DayPartition -> NonEmpty (Day, Day)
dayPartitionToNonEmpty (Bool -> Interval -> DateSpan -> Maybe DayPartition
splitSpan Bool
False ([Int] -> Interval
DaysOfWeek [Int
1, Int
5]) (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
08)))
Maybe (NonEmpty (Day, Day))
-> Maybe (NonEmpty (Day, Day)) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= NonEmpty (Day, Day) -> Maybe (NonEmpty (Day, Day))
forall a. a -> Maybe a
Just ( (Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
28, Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01) (Day, Day) -> [(Day, Day)] -> NonEmpty (Day, Day)
forall a. a -> [a] -> NonEmpty a
:|
[ (Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02, Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
04)
, (Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05, Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
08)
])
, String -> Assertion -> TestTree
testCase String
"match dayOfWeek" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
let dayofweek :: Int -> DateSpan -> Maybe DayPartition
dayofweek Int
n = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition
splitspan (Int -> Day -> Day
nthdayofweekcontaining Int
n) (\Integer
w -> (if Integer
w Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then Day -> Day
forall a. a -> a
id else Int -> (Day -> Day) -> Day -> Day
forall a. Int -> (a -> a) -> a -> a
applyN (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Day -> Day
nextday (Day -> Day) -> (Day -> Day) -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (Day -> Day) -> Day -> Day
forall a. Int -> (a -> a) -> a -> a
applyN (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
w) Day -> Day
nextweek)) Int
1
matchdow :: DateSpan -> Int -> Assertion
matchdow DateSpan
ds Int
day = Bool -> Interval -> DateSpan -> Maybe DayPartition
splitSpan Bool
False ([Int] -> Interval
DaysOfWeek [Int
day]) DateSpan
ds Maybe DayPartition -> Maybe DayPartition -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int -> DateSpan -> Maybe DayPartition
dayofweek Int
day DateSpan
ds
ys2021 :: Day
ys2021 = Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
01 Int
01
ye2021 :: Day
ye2021 = Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
12 Int
31
ys2022 :: Day
ys2022 = Integer -> Int -> Int -> Day
fromGregorian Integer
2022 Int
01 Int
01
(Int -> Assertion) -> [Int] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2021) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ye2021))) [Int
1..Int
7]
(Int -> Assertion) -> [Int] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2021) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2022))) [Int
1..Int
7]
(Int -> Assertion) -> [Int] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ye2021) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2022))) [Int
1..Int
7]
(Int -> Assertion) -> [Int] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ye2021) Maybe EFDay
forall a. Maybe a
Nothing)) [Int
1..Int
7]
(Int -> Assertion) -> [Int] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2022) Maybe EFDay
forall a. Maybe a
Nothing)) [Int
1..Int
7]
(Int -> Assertion) -> [Int] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan Maybe EFDay
forall a. Maybe a
Nothing (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ye2021))) [Int
1..Int
7]
(Int -> Assertion) -> [Int] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan Maybe EFDay
forall a. Maybe a
Nothing (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2022))) [Int
1..Int
7]
]