|
| 1 | +{-| |
| 2 | +A partition of time into contiguous spans, for defining reporting periods. |
| 3 | +-} |
| 4 | +module Hledger.Data.DayPartition |
| 5 | +( DayPartition |
| 6 | +, boundariesToDayPartition |
| 7 | +, boundariesToMaybeDayPartition |
| 8 | + |
| 9 | +, lookupDayPartition |
| 10 | +, unionDayPartitions |
| 11 | + |
| 12 | +, dayPartitionToNonEmpty |
| 13 | +, dayPartitionToList |
| 14 | +, dayPartitionToPeriodData |
| 15 | +, dayPartitionToDateSpans |
| 16 | +, maybeDayPartitionToDateSpans |
| 17 | +, dateSpansToDayPartition |
| 18 | +) where |
| 19 | + |
| 20 | +import qualified Data.IntMap.Strict as IM |
| 21 | +import Data.List.NonEmpty (NonEmpty(..)) |
| 22 | +import qualified Data.List.NonEmpty as NE |
| 23 | +import Data.Time (Day, addDays) |
| 24 | + |
| 25 | +import Hledger.Data.Dates |
| 26 | +import Hledger.Data.PeriodData |
| 27 | +import Hledger.Data.Types |
| 28 | +import Hledger.Utils |
| 29 | + |
| 30 | + |
| 31 | +-- | A partition of time into contiguous spans, along with a historical period |
| 32 | +-- before any of the spans. |
| 33 | +-- |
| 34 | +-- This is a newtype wrapper around 'PeriodData Day', where the start dates are |
| 35 | +-- the keys and the end dates are the values. Spans are stored in inclusive format |
| 36 | +-- [start, end]. Note that this differs from 'DateSpan' which uses [start, end) |
| 37 | +-- format. |
| 38 | +-- |
| 39 | +-- The constructor is not exported so that we can ensure the spans are valid |
| 40 | +-- partitions of time. |
| 41 | +newtype DayPartition = DayPartition { dayPartitionToPeriodData :: PeriodData Day } deriving (Eq, Ord, Show) |
| 42 | + |
| 43 | +-- Developer's note. All constructors must guarantee that: |
| 44 | +-- 1. The value stored in pdperiods has at least one key. |
| 45 | +-- 2. The value stored in pdpre equals one day before the smallest key in pdperiods. |
| 46 | +-- 3. The value stored in each entry of pdperiods equals one day before the |
| 47 | +-- next largest key, except for the value associated to the largest key. |
| 48 | +isValidDayPartition :: DayPartition -> Bool |
| 49 | +isValidDayPartition (DayPartition pd) = case ds of |
| 50 | + [] -> False -- Must be at least one key in pdperiods |
| 51 | + xs -> and $ zipWith isContiguous ((nulldate, h) : xs) xs |
| 52 | + where |
| 53 | + (h, ds) = periodDataToList pd |
| 54 | + isContiguous (_, e) (s, _) = addDays 1 e == s |
| 55 | + |
| 56 | + |
| 57 | +-- | Construct a 'DayPartition' from a non-empty list of boundary days. |
| 58 | +boundariesToDayPartition :: NonEmpty Day -> DayPartition |
| 59 | +boundariesToDayPartition xs = |
| 60 | + DayPartition $ periodDataFromList (addDays (-1) b) $ zip (b:bs) (map (addDays (-1)) bs) |
| 61 | + where (b:|bs) = NE.nub $ NE.sort xs |
| 62 | + |
| 63 | +-- | Construct a 'DayPartition' from a list of boundary days, returning |
| 64 | +-- 'Nothing' for the empty list. |
| 65 | +boundariesToMaybeDayPartition :: [Day] -> Maybe DayPartition |
| 66 | +boundariesToMaybeDayPartition = fmap boundariesToDayPartition . NE.nonEmpty |
| 67 | + |
| 68 | + |
| 69 | +-- | Find the span of a 'DayPartition' which contains a given day. |
| 70 | +lookupDayPartition :: Day -> DayPartition -> (Maybe Day, Day) |
| 71 | +lookupDayPartition d (DayPartition xs) = lookupPeriodDataOrHistorical d xs |
| 72 | + |
| 73 | +-- | Return the union of two 'DayPartition's if they are consistent, or 'Nothing' otherwise. |
| 74 | +unionDayPartitions :: DayPartition -> DayPartition -> Maybe DayPartition |
| 75 | +unionDayPartitions (DayPartition (PeriodData h as)) (DayPartition (PeriodData h' as')) = |
| 76 | + if equalIntersection as as' && isValidDayPartition union then Just union else Nothing |
| 77 | + where |
| 78 | + union = DayPartition . PeriodData (min h h') $ as <> as' |
| 79 | + equalIntersection x y = and $ IM.intersectionWith (==) x y |
| 80 | + |
| 81 | + |
| 82 | +-- | Convert 'DayPartition' to a non-empty list of start and end dates for the periods. |
| 83 | +-- |
| 84 | +-- Note that the end date of each period will be one day before the start date |
| 85 | +-- of the next period. |
| 86 | +dayPartitionToNonEmpty :: DayPartition -> NonEmpty (Day, Day) |
| 87 | +dayPartitionToNonEmpty (DayPartition xs) = NE.fromList . snd $ periodDataToList xs -- Constructors guarantee this is non-empty |
| 88 | + |
| 89 | +-- | Convert 'DayPartition' to a list of start and end dates for the periods. |
| 90 | +-- |
| 91 | +-- Note that the end date of each period will be one day before the start date |
| 92 | +-- of the next period. |
| 93 | +dayPartitionToList :: DayPartition -> [(Day, Day)] |
| 94 | +dayPartitionToList = NE.toList . dayPartitionToNonEmpty |
| 95 | + |
| 96 | +-- | Convert 'DayPartition' to a list of 'DateSpan's. |
| 97 | +-- |
| 98 | +-- Note that the end date of each period will be equal to the start date of |
| 99 | +-- the next period. |
| 100 | +dayPartitionToDateSpans :: DayPartition -> [DateSpan] |
| 101 | +dayPartitionToDateSpans = map toDateSpan . dayPartitionToList |
| 102 | + where |
| 103 | + toDateSpan (s, e) = DateSpan (toEFDay s) (toEFDay $ addDays 1 e) |
| 104 | + toEFDay = Just . Exact |
| 105 | + |
| 106 | +-- Convert a periodic report 'Maybe DayPartition' to a list of 'DateSpans', |
| 107 | +-- replacing the empty case with an appropriate placeholder. |
| 108 | +-- |
| 109 | +-- Note that the end date of each period will be equal to the start date of |
| 110 | +-- the next period. |
| 111 | +maybeDayPartitionToDateSpans :: Maybe DayPartition -> [DateSpan] |
| 112 | +maybeDayPartitionToDateSpans = maybe [DateSpan Nothing Nothing] dayPartitionToDateSpans |
| 113 | + |
| 114 | +-- | Convert a list of 'DateSpan's to a 'DayPartition', or 'Nothing' if it is not well-formed. |
| 115 | +-- |
| 116 | +-- Warning: This can construct ill-formed 'DayPartitions' and can raise errors. |
| 117 | +-- It will be eliminated later. |
| 118 | +-- PARTIAL: |
| 119 | +dateSpansToDayPartition :: [DateSpan] -> Maybe DayPartition |
| 120 | +-- Handle the cases of partitions which would arise from journals with no transactions |
| 121 | +dateSpansToDayPartition [] = Nothing |
| 122 | +dateSpansToDayPartition [DateSpan Nothing Nothing] = Nothing |
| 123 | +dateSpansToDayPartition [DateSpan Nothing (Just _)] = Nothing |
| 124 | +dateSpansToDayPartition [DateSpan (Just _) Nothing] = Nothing |
| 125 | +-- Handle properly defined reports |
| 126 | +dateSpansToDayPartition (x:xs) = Just . DayPartition $ |
| 127 | + periodDataFromList (addDays (-1) . fst $ boundaries x) (map boundaries (x:xs)) |
| 128 | + where |
| 129 | + boundaries spn = makeJust (spanStart spn, addDays (-1) <$> spanEnd spn) |
| 130 | + makeJust (Just a, Just b) = (a, b) |
| 131 | + makeJust ab = error' $ "dateSpansToDayPartition: expected all spans to have start and end dates, but one has " ++ show ab |
0 commit comments