mirror of
https://github.com/facebook/duckling.git
synced 2024-09-11 21:27:13 +03:00
Summary: Add the most common rules for Japanese time dimension. Pull Request resolved: https://github.com/facebook/duckling/pull/646 Reviewed By: stroxler Differential Revision: D30675005 Pulled By: chessai fbshipit-source-id: 917aa98b5cfe0c73d207b1f51b80d8e17a1c7e6a
763 lines
25 KiB
Haskell
763 lines
25 KiB
Haskell
-- Copyright (c) 2016-present, Facebook, Inc.
|
|
-- All rights reserved.
|
|
--
|
|
-- This source code is licensed under the BSD-style license found in the
|
|
-- LICENSE file in the root directory of this source tree.
|
|
|
|
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE NoRebindableSyntax #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Duckling.Time.Helpers
|
|
( -- Patterns
|
|
hasNoDirection, isADayOfWeek, isAMonth, isAnHourOfDay, isAPartOfDay
|
|
, isATimeOfDay, isDurationGreaterThan, isDOMInteger, isDOMOrdinal, isDOMValue
|
|
, isGrainFinerThan, isGrainCoarserThan, isGrainOfTime
|
|
, isIntegerBetween, isNotLatent , isOrdinalBetween, isMidnightOrNoon
|
|
, isOkWithThisNext, sameGrain, hasTimezone, hasNoTimezone, today
|
|
-- Production
|
|
, cycleLastOf, cycleN, cycleNth, cycleNthAfter, dayOfMonth, dayOfWeek
|
|
, durationAfter, durationAgo, durationBefore, mkOkForThisNext, form, hour
|
|
, hourMinute, hourMinuteSecond, inDuration, intersect, intersectDOM, interval
|
|
, inTimezone, longWEBefore, minute, minutesAfter, minutesBefore, mkLatent
|
|
, month, monthDay, notLatent, now, nthDOWOfMonth, partOfDay, predLastOf
|
|
, predNth, predNthAfter, predNthClosest, season, second, timeOfDayAMPM
|
|
, weekday, weekend, workweek, withDirection, year, yearMonthDay, tt, durationIntervalAgo
|
|
, inDurationInterval, intersectWithReplacement, yearADBC, yearMonth
|
|
, predEveryNDaysFrom, timeCycle
|
|
-- Other
|
|
, getIntValue, timeComputed, toTimeObjectM
|
|
-- Rule constructors
|
|
, mkRuleInstants
|
|
, mkRuleDaysOfWeek, mkRuleDaysOfWeekLatent
|
|
, mkRuleMonths, mkRuleMonthsWithLatent
|
|
, mkRuleSeasons, mkRuleHolidays, mkRuleHolidays'
|
|
) where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Data.Maybe
|
|
import Data.Ord (comparing)
|
|
import Data.Text (Text)
|
|
import Data.Tuple.Extra (both)
|
|
import Prelude hiding (pred)
|
|
import qualified Data.Time as Time
|
|
import qualified Data.Time.LocalTime.TimeZone.Series as Series
|
|
|
|
import Duckling.Dimensions.Types
|
|
import Duckling.Duration.Types (DurationData (DurationData))
|
|
import Duckling.Ordinal.Types (OrdinalData (OrdinalData))
|
|
import Duckling.Time.TimeZone.Parse (parseTimezone)
|
|
import Duckling.Time.Types
|
|
( TimeData(TimeData)
|
|
, mkSeriesPredicate
|
|
, mkSecondPredicate
|
|
, mkMinutePredicate
|
|
, mkHourPredicate
|
|
, mkAMPMPredicate
|
|
, mkMonthPredicate
|
|
, mkDayOfTheWeekPredicate
|
|
, mkDayOfTheMonthPredicate
|
|
, mkYearPredicate
|
|
, mkIntersectPredicate
|
|
, mkTimeIntervalsPredicate
|
|
, mkReplaceIntersectPredicate
|
|
, runPredicate
|
|
, AMPM(..)
|
|
)
|
|
import Duckling.Types
|
|
( Predicate
|
|
, Token(..)
|
|
, regex
|
|
, Rule
|
|
)
|
|
import qualified Duckling.Types as Types
|
|
import qualified Duckling.Duration.Types as TDuration
|
|
import qualified Duckling.Numeral.Types as TNumeral
|
|
import qualified Duckling.Ordinal.Types as TOrdinal
|
|
import qualified Duckling.Time.Types as TTime
|
|
import qualified Duckling.TimeGrain.Types as TG
|
|
|
|
getIntValue :: Token -> Maybe Int
|
|
getIntValue (Token Numeral nd) = TNumeral.getIntValue $ TNumeral.value nd
|
|
getIntValue (Token Ordinal OrdinalData {TOrdinal.value = x}) = Just x
|
|
getIntValue _ = Nothing
|
|
|
|
timeNegPeriod :: DurationData -> DurationData
|
|
timeNegPeriod (DurationData v g) = DurationData
|
|
{TDuration.grain = g, TDuration.value = negate v}
|
|
|
|
timeShiftPeriod :: Int -> DurationData -> DurationData
|
|
timeShiftPeriod n dd@DurationData{TDuration.value = v} =
|
|
dd{TDuration.value = v + n}
|
|
|
|
-- -----------------------------------------------------------------
|
|
-- Time predicates
|
|
|
|
timeComputed :: [TTime.TimeObject] -> TTime.Predicate
|
|
timeComputed xs = mkSeriesPredicate series
|
|
where
|
|
series t _ = (reverse start, end)
|
|
where
|
|
(start, end) = span (`TTime.timeBefore` t) xs
|
|
|
|
timeCycle :: TG.Grain -> TTime.Predicate
|
|
timeCycle grain = mkSeriesPredicate series
|
|
where
|
|
series t _ = TTime.timeSequence grain 1 $ TTime.timeRound t grain
|
|
|
|
timeSecond :: Int -> TTime.Predicate
|
|
timeSecond n = mkSecondPredicate n
|
|
|
|
timeMinute :: Int -> TTime.Predicate
|
|
timeMinute n = mkMinutePredicate n
|
|
|
|
timeHour :: Bool -> Int -> TTime.Predicate
|
|
timeHour is12H n = mkHourPredicate is12H n
|
|
|
|
timeDayOfWeek :: Int -> TTime.Predicate
|
|
timeDayOfWeek n = mkDayOfTheWeekPredicate n
|
|
|
|
timeDayOfMonth :: Int -> TTime.Predicate
|
|
timeDayOfMonth n = mkDayOfTheMonthPredicate n
|
|
|
|
timeMonth :: Int -> TTime.Predicate
|
|
timeMonth n = mkMonthPredicate n
|
|
|
|
timeYear :: Int -> TTime.Predicate
|
|
timeYear n = mkYearPredicate n
|
|
|
|
-- | Takes `n` cycles of `f`
|
|
takeN :: Int -> Bool -> TTime.Predicate -> TTime.Predicate
|
|
takeN n notImmediate f = mkSeriesPredicate series
|
|
where
|
|
series t context =
|
|
case slot of
|
|
Just nth -> if TTime.timeStartsBeforeTheEndOf t nth
|
|
then ([], [nth])
|
|
else ([nth], [])
|
|
Nothing -> ([], [])
|
|
where
|
|
baseTime = TTime.refTime context
|
|
(past, future) = runPredicate f baseTime context
|
|
fut = case future of
|
|
(ahead:rest)
|
|
| notImmediate && isJust (TTime.timeIntersect ahead baseTime) -> rest
|
|
_ -> future
|
|
slot = if n >= 0
|
|
then case fut of
|
|
(start:_) -> case drop n fut of
|
|
(end:_) -> Just $ TTime.timeInterval TTime.Open start end
|
|
_ -> Nothing
|
|
_ -> Nothing
|
|
else case past of
|
|
(end:_) -> case drop ((- n) - 1) past of
|
|
(start:_) -> Just $ TTime.timeInterval TTime.Closed start end
|
|
_ -> Nothing
|
|
_ -> Nothing
|
|
|
|
-- | -1 is the first element in the past
|
|
-- | 0 is the first element in the future
|
|
takeNth :: Int -> Bool -> TTime.Predicate -> TTime.Predicate
|
|
takeNth n notImmediate f = mkSeriesPredicate series
|
|
where
|
|
series t context =
|
|
case rest of
|
|
[] -> ([], [])
|
|
(nth:_) -> if TTime.timeStartsBeforeTheEndOf t nth
|
|
then ([], [nth])
|
|
else ([nth], [])
|
|
where
|
|
baseTime = TTime.refTime context
|
|
(past, future) = runPredicate f baseTime context
|
|
rest = if n >= 0
|
|
then case future of
|
|
(ahead:_) | notImmediate && isJust (TTime.timeIntersect ahead baseTime)
|
|
-> drop (n + 1) future
|
|
_ -> drop n future
|
|
else drop (- (n + 1)) past
|
|
|
|
-- | Like `takeNth`, but takes the nth cyclic predicate after `basePred`
|
|
takeNthAfter
|
|
:: Int
|
|
-> Bool
|
|
-> TTime.Predicate
|
|
-> TTime.Predicate
|
|
-> TTime.Predicate
|
|
takeNthAfter n notImmediate cyclicPred basePred =
|
|
mkSeriesPredicate $! TTime.timeSeqMap False f basePred
|
|
where
|
|
f t ctx =
|
|
let (past, future) = runPredicate cyclicPred t ctx
|
|
rest = if n >= 0
|
|
then case future of
|
|
(ahead:_) | notImmediate && TTime.timeBefore ahead t
|
|
-> drop (n + 1) future
|
|
_ -> drop n future
|
|
else drop (- (n + 1)) past
|
|
in case rest of
|
|
[] -> Nothing
|
|
(nth:_) -> Just nth
|
|
|
|
-- | Take the nth closest value to `basePred` among those yielded by
|
|
-- `cyclicPred`.
|
|
-- n = 0 is the closest value, n = 1 is the second closest value, etc.
|
|
-- n < 0 is treated as n = 0.
|
|
takeNthClosest :: Int -> TTime.Predicate -> TTime.Predicate -> TTime.Predicate
|
|
takeNthClosest n cyclicPred basePred =
|
|
mkSeriesPredicate $! TTime.timeSeqMap False f basePred
|
|
where
|
|
f t ctx = mth (n `max` 0) past future Nothing
|
|
where
|
|
(past, future) = runPredicate cyclicPred t ctx
|
|
mth m pa fu res
|
|
| m < 0 = res
|
|
| otherwise = case comparing against x y of
|
|
GT -> mth (m-1) (tailSafe pa) fu x
|
|
_ -> mth (m-1) pa (tailSafe fu) y
|
|
where (x,y) = both listToMaybe (pa,fu)
|
|
against :: Maybe TTime.TimeObject -> Maybe Time.NominalDiffTime
|
|
against = fmap (negate . TTime.diffStartTime t)
|
|
tailSafe :: [a] -> [a]
|
|
tailSafe (_:xs) = xs
|
|
tailSafe [] = []
|
|
|
|
-- | Takes the last occurrence of `cyclicPred` within `basePred`.
|
|
takeLastOf :: TTime.Predicate -> TTime.Predicate -> TTime.Predicate
|
|
takeLastOf cyclicPred basePred =
|
|
mkSeriesPredicate $! TTime.timeSeqMap False f basePred
|
|
where
|
|
f :: TTime.TimeObject -> TTime.TimeContext -> Maybe TTime.TimeObject
|
|
f t ctx =
|
|
case runPredicate cyclicPred (TTime.timeStartingAtTheEndOf t) ctx of
|
|
(nth:_, _) -> Just nth
|
|
_ -> Nothing
|
|
|
|
-- | Assumes the grain of `pred1` is smaller than the one of `pred2`
|
|
timeCompose :: TTime.Predicate -> TTime.Predicate -> TTime.Predicate
|
|
timeCompose pred1 pred2 = mkIntersectPredicate pred1 pred2
|
|
|
|
timeComposeWithReplacement
|
|
:: TTime.Predicate -> TTime.Predicate -> TTime.Predicate -> TTime.Predicate
|
|
timeComposeWithReplacement pred1 pred2 pred3 =
|
|
mkReplaceIntersectPredicate pred1 pred2 pred3
|
|
|
|
addDuration :: DurationData -> TTime.TimeObject -> TTime.TimeObject
|
|
addDuration (DurationData n g) t = TTime.timePlus t g $ toInteger n
|
|
|
|
mergeDuration :: TTime.Predicate -> DurationData -> TTime.Predicate
|
|
mergeDuration pred1 dd@(DurationData _ g) =
|
|
mkSeriesPredicate $! TTime.timeSeqMap False f pred1
|
|
where
|
|
f x@TTime.TimeObject{TTime.grain = tg} _ = Just $ addDuration dd t'
|
|
where
|
|
g' = min tg g
|
|
t' = if g' == tg then x else TTime.timeRound x g'
|
|
|
|
shiftDuration :: TTime.Predicate -> DurationData -> TTime.Predicate
|
|
shiftDuration pred1 dd@(DurationData _ g) =
|
|
mkSeriesPredicate $! TTime.timeSeqMap False f pred1
|
|
where
|
|
f x _ = Just $ addDuration dd $ TTime.timeRound x $ TG.lower g
|
|
|
|
shiftTimezone :: Series.TimeZoneSeries -> TTime.Predicate -> TTime.Predicate
|
|
shiftTimezone providedSeries pred1 =
|
|
mkSeriesPredicate $! TTime.timeSeqMap False f pred1
|
|
where
|
|
f x@(TTime.TimeObject s _ _) ctx =
|
|
let Time.TimeZone ctxOffset _ _ =
|
|
Series.timeZoneFromSeries (TTime.tzSeries ctx) s
|
|
Time.TimeZone providedOffset _ _ =
|
|
Series.timeZoneFromSeries providedSeries s
|
|
-- This forgets about TTime.end, but it's OK since we act on time-of-days.
|
|
in Just $ TTime.timePlus x TG.Minute $ toInteger $
|
|
ctxOffset - providedOffset
|
|
|
|
-- -----------------------------------------------------------------
|
|
-- Patterns
|
|
|
|
isGrainFinerThan :: TG.Grain -> Predicate
|
|
isGrainFinerThan value (Token Time TimeData{TTime.timeGrain = g}) = g < value
|
|
isGrainFinerThan _ _ = False
|
|
|
|
isGrainCoarserThan :: TG.Grain -> Predicate
|
|
isGrainCoarserThan value (Token Time TimeData{TTime.timeGrain = g}) = g > value
|
|
isGrainCoarserThan _ _ = False
|
|
|
|
isGrainOfTime :: TG.Grain -> Predicate
|
|
isGrainOfTime value (Token Time TimeData{TTime.timeGrain = g}) = g == value
|
|
isGrainOfTime _ _ = False
|
|
|
|
sameGrain :: TimeData -> TimeData -> Bool
|
|
sameGrain TimeData{TTime.timeGrain = g} TimeData{TTime.timeGrain = h} = g == h
|
|
|
|
hasTimezone :: Predicate
|
|
hasTimezone (Token Time TimeData{TTime.hasTimezone = tz}) = tz
|
|
hasTimezone _ = False
|
|
|
|
hasNoTimezone :: Predicate
|
|
hasNoTimezone = not . hasTimezone
|
|
|
|
isADayOfWeek :: Predicate
|
|
isADayOfWeek (Token Time td) = case TTime.form td of
|
|
Just TTime.DayOfWeek -> True
|
|
_ -> False
|
|
isADayOfWeek _ = False
|
|
|
|
isATimeOfDay :: Predicate
|
|
isATimeOfDay (Token Time td) = case TTime.form td of
|
|
Just (TTime.TimeOfDay _ _) -> True
|
|
_ -> False
|
|
isATimeOfDay _ = False
|
|
|
|
isAPartOfDay :: Predicate
|
|
isAPartOfDay (Token Time td) = case TTime.form td of
|
|
Just TTime.PartOfDay -> True
|
|
_ -> False
|
|
isAPartOfDay _ = False
|
|
|
|
isAMonth :: Predicate
|
|
isAMonth (Token Time td) = case TTime.form td of
|
|
Just (TTime.Month _) -> True
|
|
_ -> False
|
|
isAMonth _ = False
|
|
|
|
isAnHourOfDay :: Predicate
|
|
isAnHourOfDay (Token Time td) = case TTime.form td of
|
|
Just (TTime.TimeOfDay (Just _) _) | TTime.timeGrain td > TG.Minute -> True
|
|
_ -> False
|
|
isAnHourOfDay _ = False
|
|
|
|
isMidnightOrNoon :: Predicate
|
|
isMidnightOrNoon (Token Time td) = case TTime.form td of
|
|
Just (TTime.TimeOfDay (Just x) _) -> x == 0 || x == 12
|
|
_ -> False
|
|
isMidnightOrNoon _ = False
|
|
|
|
isNotLatent :: Predicate
|
|
isNotLatent (Token Time td) = not $ TTime.latent td
|
|
isNotLatent _ = False
|
|
|
|
hasNoDirection :: Predicate
|
|
hasNoDirection (Token Time td) = isNothing $ TTime.direction td
|
|
hasNoDirection _ = False
|
|
|
|
isIntegerBetween :: Int -> Int -> Predicate
|
|
isIntegerBetween low high (Token Numeral nd) = TNumeral.okForAnyTime nd
|
|
&& TNumeral.isIntegerBetween (TNumeral.value nd) low high
|
|
isIntegerBetween _ _ _ = False
|
|
|
|
isOrdinalBetween :: Int -> Int -> Predicate
|
|
isOrdinalBetween low high (Token Ordinal od) =
|
|
TOrdinal.isBetween (TOrdinal.value od) low high
|
|
isOrdinalBetween _ _ _ = False
|
|
|
|
isDurationGreaterThan :: TG.Grain -> Predicate
|
|
isDurationGreaterThan value (Token Duration DurationData{TDuration.grain = grain}) = grain > value
|
|
isDurationGreaterThan _ _ = False
|
|
|
|
isDOMOrdinal :: Predicate
|
|
isDOMOrdinal = isOrdinalBetween 1 31
|
|
|
|
isDOMInteger :: Predicate
|
|
isDOMInteger = isIntegerBetween 1 31
|
|
|
|
isDOMValue :: Predicate
|
|
isDOMValue = or . sequence [isDOMOrdinal, isDOMInteger]
|
|
|
|
isOkWithThisNext :: Predicate
|
|
isOkWithThisNext (Token Time TimeData {TTime.okForThisNext = True}) = True
|
|
isOkWithThisNext _ = False
|
|
|
|
-- -----------------------------------------------------------------
|
|
-- Production
|
|
|
|
-- Pass the interval second
|
|
intersect :: TimeData -> TimeData -> Maybe TimeData
|
|
intersect td1 td2 =
|
|
case intersect' (td1, td2) of
|
|
TTime.TimeData { TTime.timePred = pred }
|
|
| TTime.isEmptyPredicate pred -> Nothing
|
|
res -> Just res
|
|
|
|
intersectWithReplacement :: TimeData -> TimeData -> TimeData -> Maybe TimeData
|
|
intersectWithReplacement
|
|
(TimeData pred1 _ g1 _ _ _ _ h1 _)
|
|
(TimeData pred2 _ g2 _ _ _ _ h2 _)
|
|
(TimeData pred3 _ g3 _ _ _ _ h3 _)
|
|
| g1 == g2 && g2 == g3 = Just $ TTime.timedata'
|
|
{ TTime.timePred = timeComposeWithReplacement pred1 pred2 pred3
|
|
, TTime.timeGrain = g1
|
|
, TTime.direction = Nothing
|
|
, TTime.holiday = h1 <|> h2 <|> h3
|
|
}
|
|
| otherwise = Nothing
|
|
|
|
intersect' :: (TimeData, TimeData) -> TimeData
|
|
intersect' (TimeData pred1 _ g1 _ _ d1 _ h1 _, TimeData pred2 _ g2 _ _ d2 _ h2 _)
|
|
| g1 < g2 = TTime.timedata'
|
|
{ TTime.timePred = timeCompose pred1 pred2
|
|
, TTime.timeGrain = g1
|
|
, TTime.direction = d1 <|> d2
|
|
, TTime.holiday = h1 <|> h2
|
|
}
|
|
| otherwise = TTime.timedata'
|
|
{ TTime.timePred = timeCompose pred2 pred1
|
|
, TTime.timeGrain = g2
|
|
, TTime.direction = d1 <|> d2
|
|
, TTime.holiday = h1 <|> h2
|
|
}
|
|
|
|
now :: TimeData
|
|
now = td {TTime.timeGrain = TG.NoGrain}
|
|
where
|
|
td = cycleNth TG.Second 0
|
|
|
|
today :: TimeData
|
|
today = cycleNth TG.Day 0
|
|
|
|
hour :: Bool -> Int -> TimeData
|
|
hour is12H n = timeOfDay (Just n) is12H $ TTime.timedata'
|
|
{TTime.timePred = timeHour is12H n, TTime.timeGrain = TG.Hour}
|
|
|
|
minute :: Int -> TimeData
|
|
minute n = TTime.timedata'
|
|
{TTime.timePred = timeMinute n, TTime.timeGrain = TG.Minute}
|
|
|
|
second :: Int -> TimeData
|
|
second n = TTime.timedata'
|
|
{TTime.timePred = timeSecond n, TTime.timeGrain = TG.Second}
|
|
|
|
dayOfWeek :: Int -> TimeData
|
|
dayOfWeek n = form TTime.DayOfWeek $ TTime.timedata'
|
|
{ TTime.timePred = timeDayOfWeek n
|
|
, TTime.timeGrain = TG.Day
|
|
, TTime.notImmediate = True
|
|
}
|
|
|
|
dayOfMonth :: Int -> TimeData
|
|
dayOfMonth n = TTime.timedata'
|
|
{TTime.timePred = timeDayOfMonth n, TTime.timeGrain = TG.Day}
|
|
|
|
month :: Int -> TimeData
|
|
month n = form TTime.Month {TTime.month = n} $ TTime.timedata'
|
|
{TTime.timePred = timeMonth n, TTime.timeGrain = TG.Month}
|
|
|
|
-- | Converts 2-digits to a year between 1950 and 2050
|
|
year :: Int -> TimeData
|
|
year n = TTime.timedata'{TTime.timePred = timeYear y, TTime.timeGrain = TG.Year}
|
|
where
|
|
y = if n <= 99 then mod (n + 50) 100 + 2000 - 50 else n
|
|
|
|
yearADBC :: Int -> TimeData
|
|
yearADBC n =
|
|
TTime.timedata'{TTime.timePred = timeYear n, TTime.timeGrain = TG.Year}
|
|
|
|
yearMonth :: Int -> Int -> TimeData
|
|
yearMonth y m = intersect' (year y, month m)
|
|
|
|
yearMonthDay :: Int -> Int -> Int -> TimeData
|
|
yearMonthDay y m d = intersect' (yearMonth y m, dayOfMonth d)
|
|
|
|
monthDay :: Int -> Int -> TimeData
|
|
monthDay m d = intersect' (month m, dayOfMonth d)
|
|
|
|
hourMinute :: Bool -> Int -> Int -> TimeData
|
|
hourMinute is12H h m = timeOfDay (Just h) is12H $
|
|
intersect' (hour is12H h, minute m)
|
|
|
|
hourMinuteSecond :: Bool -> Int -> Int -> Int -> TimeData
|
|
hourMinuteSecond is12H h m s = timeOfDay (Just h) is12H $
|
|
intersect' (intersect' (hour is12H h, minute m), second s)
|
|
|
|
season :: TimeData
|
|
season = TTime.timedata'
|
|
{ TTime.timePred = TTime.seasonPredicate
|
|
, TTime.timeGrain = TG.Day
|
|
}
|
|
|
|
-- | Note that this function is not the counterpart of `weekend`.
|
|
-- `weekend` returns an interval while `weekday` returns a single day.
|
|
weekday :: TimeData
|
|
weekday = TTime.timedata'
|
|
{ TTime.timePred = TTime.weekdayPredicate
|
|
, TTime.timeGrain = TG.Day
|
|
}
|
|
|
|
cycleN :: Bool -> TG.Grain -> Int -> TimeData
|
|
cycleN notImmediate grain n = TTime.timedata'
|
|
{ TTime.timePred = takeN n notImmediate $ timeCycle grain
|
|
, TTime.timeGrain = grain
|
|
}
|
|
|
|
cycleNth :: TG.Grain -> Int -> TimeData
|
|
cycleNth grain n = TTime.timedata'
|
|
{TTime.timePred = takeNth n False $ timeCycle grain, TTime.timeGrain = grain}
|
|
|
|
cycleNthAfter :: Bool -> TG.Grain -> Int -> TimeData -> TimeData
|
|
cycleNthAfter notImmediate grain n TimeData {TTime.timePred = p} =
|
|
TTime.timedata'
|
|
{ TTime.timePred = takeNthAfter n notImmediate (timeCycle grain) p
|
|
, TTime.timeGrain = grain
|
|
}
|
|
|
|
cycleLastOf :: TG.Grain -> TimeData -> TimeData
|
|
cycleLastOf grain TimeData {TTime.timePred = p} = TTime.timedata'
|
|
{ TTime.timePred = takeLastOf (timeCycle grain) p
|
|
, TTime.timeGrain = grain
|
|
}
|
|
|
|
-- Generalized version of cycleLastOf with custom predicate
|
|
predLastOf :: TimeData -> TimeData -> TimeData
|
|
predLastOf TimeData {TTime.timePred = cyclicPred, TTime.timeGrain = g} base =
|
|
TTime.timedata'
|
|
{ TTime.timePred = takeLastOf cyclicPred $ TTime.timePred base
|
|
, TTime.timeGrain = g
|
|
}
|
|
|
|
-- Generalized version of cycleNth with custom predicate
|
|
predNth :: Int -> Bool -> TimeData -> TimeData
|
|
predNth n notImmediate TimeData
|
|
{TTime.timePred = p, TTime.timeGrain = g, TTime.holiday = h} =
|
|
TTime.timedata'
|
|
{TTime.timePred = takeNth n notImmediate p
|
|
, TTime.timeGrain = g
|
|
, TTime.holiday = h}
|
|
|
|
-- Generalized version of `cycleNthAfter` with custom predicate
|
|
predNthAfter :: Int -> TimeData -> TimeData -> TimeData
|
|
predNthAfter n TimeData
|
|
{TTime.timePred = p, TTime.timeGrain = g, TTime.holiday = h} base =
|
|
TTime.timedata'
|
|
{ TTime.timePred = takeNthAfter n True p $ TTime.timePred base
|
|
, TTime.timeGrain = g
|
|
, TTime.holiday = h
|
|
}
|
|
|
|
-- This function can be used to express predicates invoving "closest",
|
|
-- such as "the second closest Monday to Oct 5th"
|
|
predNthClosest :: Int -> TimeData -> TimeData -> TimeData
|
|
predNthClosest n TimeData
|
|
{TTime.timePred = p, TTime.timeGrain = g, TTime.holiday = h} base =
|
|
TTime.timedata'
|
|
{ TTime.timePred = takeNthClosest n p $ TTime.timePred base
|
|
, TTime.timeGrain = g
|
|
, TTime.holiday = h
|
|
}
|
|
|
|
-- This function is used for periodic events, for example,
|
|
-- "every 365 days" or "every 8 years".
|
|
-- `given` is a known example of the event.
|
|
-- Do not export
|
|
predEveryFrom :: TG.Grain -> Int -> TTime.TimeObject -> TimeData
|
|
predEveryFrom periodGrain period given = TTime.timedata'
|
|
{ TTime.timePred = TTime.periodicPredicate periodGrain period given
|
|
, TTime.timeGrain = TTime.grain given
|
|
}
|
|
|
|
predEveryNDaysFrom :: Int -> (Integer, Int, Int) -> Maybe TimeData
|
|
predEveryNDaysFrom period given = do
|
|
date <- toTimeObjectM given
|
|
return $ predEveryFrom TG.Day period date
|
|
|
|
toTimeObjectM :: (Integer, Int, Int) -> Maybe TTime.TimeObject
|
|
toTimeObjectM (y, m, d) = do
|
|
day <- Time.fromGregorianValid y m d
|
|
return TTime.TimeObject
|
|
{ TTime.start = Time.UTCTime day 0
|
|
, TTime.grain = TG.Day
|
|
, TTime.end = Nothing
|
|
}
|
|
|
|
interval' :: TTime.TimeIntervalType -> (TimeData, TimeData) -> TimeData
|
|
interval' intervalType (TimeData p1 _ g1 _ _ _ _ _ _, TimeData p2 _ g2 _ _ _ _ _ _) =
|
|
TTime.timedata'
|
|
{ TTime.timePred = mkTimeIntervalsPredicate intervalType' p1 p2
|
|
, TTime.timeGrain = min g1 g2
|
|
}
|
|
where
|
|
intervalType'
|
|
| g1 == g2 && g1 == TG.Day = TTime.Closed
|
|
| otherwise = intervalType
|
|
|
|
interval :: TTime.TimeIntervalType -> TimeData -> TimeData -> Maybe TimeData
|
|
interval intervalType td1 td2 =
|
|
case interval' intervalType (td1, td2) of
|
|
TTime.TimeData { TTime.timePred = pred }
|
|
| TTime.isEmptyPredicate pred -> Nothing
|
|
res -> Just res
|
|
|
|
mkOkForThisNext :: TimeData -> TimeData
|
|
mkOkForThisNext td = td {TTime.okForThisNext = True}
|
|
|
|
durationAgo :: DurationData -> TimeData
|
|
durationAgo dd = inDuration $ timeNegPeriod dd
|
|
|
|
durationIntervalAgo :: DurationData -> TimeData
|
|
durationIntervalAgo dd = inDurationInterval $ timeNegPeriod dd
|
|
|
|
durationAfter :: DurationData -> TimeData -> TimeData
|
|
durationAfter dd TimeData {TTime.timePred = pred1, TTime.timeGrain = g} =
|
|
TTime.timedata'
|
|
{ TTime.timePred = if g == TG.NoGrain
|
|
then shiftDuration pred1 dd
|
|
else mergeDuration pred1 dd
|
|
, TTime.timeGrain = TDuration.grain dd
|
|
}
|
|
|
|
durationBefore :: DurationData -> TimeData -> TimeData
|
|
durationBefore dd pred1 = durationAfter (timeNegPeriod dd) pred1
|
|
|
|
inDuration :: DurationData -> TimeData
|
|
inDuration dd = TTime.timedata'
|
|
{ TTime.timePred = shiftDuration t dd
|
|
, TTime.timeGrain = TDuration.grain dd
|
|
}
|
|
where
|
|
t = takeNth 0 False $ timeCycle TG.Second
|
|
|
|
inDurationInterval :: DurationData -> TimeData
|
|
inDurationInterval dd = interval' TTime.Open
|
|
(inDuration dd, inDuration $ timeShiftPeriod 1 dd)
|
|
|
|
inTimezone :: Text -> TimeData -> Maybe TimeData
|
|
inTimezone input td@TimeData {TTime.timePred = p} = do
|
|
tz <- parseTimezone input
|
|
Just $ td {TTime.timePred = shiftTimezone (Series.TimeZoneSeries tz []) p, TTime.hasTimezone = True}
|
|
|
|
withHoliday :: Text -> TimeData -> TimeData
|
|
withHoliday n td = td {TTime.holiday = Just n}
|
|
|
|
mkLatent :: TimeData -> TimeData
|
|
mkLatent td = td {TTime.latent = True}
|
|
|
|
notLatent :: TimeData -> TimeData
|
|
notLatent td = td {TTime.latent = False}
|
|
|
|
form :: TTime.Form -> TimeData -> TimeData
|
|
form f td = td {TTime.form = Just f}
|
|
|
|
partOfDay :: TimeData -> TimeData
|
|
partOfDay td = form TTime.PartOfDay td
|
|
|
|
timeOfDay :: Maybe Int -> Bool -> TimeData -> TimeData
|
|
timeOfDay h is12H = form TTime.TimeOfDay {TTime.hours = h, TTime.is12H = is12H}
|
|
|
|
timeOfDayAMPM :: Bool -> TimeData -> TimeData
|
|
timeOfDayAMPM isAM tod = timeOfDay Nothing False $ intersect' (tod, ampm)
|
|
where
|
|
ampm = TTime.timedata'
|
|
{ TTime.timePred = ampmPred
|
|
, TTime.timeGrain = TG.Hour
|
|
}
|
|
ampmPred = if isAM then mkAMPMPredicate AM else mkAMPMPredicate PM
|
|
|
|
withDirection :: TTime.IntervalDirection -> TimeData -> TimeData
|
|
withDirection dir td = td {TTime.direction = Just dir}
|
|
|
|
longWEBefore :: TimeData -> TimeData
|
|
longWEBefore monday = interval' TTime.Open (start, end)
|
|
where
|
|
start = intersect' (fri, hour False 18)
|
|
end = intersect' (tue, hour False 0)
|
|
fri = cycleNthAfter False TG.Day (- 3) monday
|
|
tue = cycleNthAfter False TG.Day 1 monday
|
|
|
|
weekend :: TimeData
|
|
weekend = interval' TTime.Open (fri, mon)
|
|
where
|
|
fri = intersect' (dayOfWeek 5, hour False 18)
|
|
mon = intersect' (dayOfWeek 1, hour False 0)
|
|
|
|
workweek :: TimeData
|
|
workweek = interval' TTime.Open (mon, fri)
|
|
where
|
|
mon = intersect' (dayOfWeek 1, hour False 10)
|
|
fri = intersect' (dayOfWeek 5, hour False 18)
|
|
|
|
-- Zero-indexed weeks, Monday is 1
|
|
-- Use `predLastOf` for last day of week of month
|
|
nthDOWOfMonth :: Int -> Int -> Int -> TimeData
|
|
nthDOWOfMonth n dow m = predNthAfter (n - 1) dow_ month_
|
|
where
|
|
dow_ = dayOfWeek dow
|
|
month_ = month m
|
|
|
|
intersectDOM :: TimeData -> Token -> Maybe TimeData
|
|
intersectDOM td token = do
|
|
n <- getIntValue token
|
|
intersect (dayOfMonth n) td
|
|
|
|
minutesBefore :: Int -> TimeData -> Maybe TimeData
|
|
minutesBefore n TimeData {TTime.form = Just (TTime.TimeOfDay (Just 0) is12H)} =
|
|
Just $ hourMinute is12H 23 (60 - n)
|
|
minutesBefore n TimeData {TTime.form = Just (TTime.TimeOfDay (Just 1) True)} =
|
|
Just $ hourMinute True 12 (60 - n)
|
|
minutesBefore n TimeData {TTime.form = Just (TTime.TimeOfDay (Just h) is12H)} =
|
|
Just $ hourMinute is12H (h - 1) (60 - n)
|
|
minutesBefore _ _ = Nothing
|
|
|
|
minutesAfter :: Int -> TimeData -> Maybe TimeData
|
|
minutesAfter n TimeData {TTime.form = Just (TTime.TimeOfDay (Just h) is12H)} =
|
|
Just $ hourMinute is12H h n
|
|
minutesAfter _ _ = Nothing
|
|
|
|
-- | Convenience helper to return a time token from a rule
|
|
tt :: TimeData -> Maybe Token
|
|
tt = Just . Token Time
|
|
|
|
-- | Rule constructors
|
|
mkSingleRegexRule :: Text -> String -> Maybe Token -> Rule
|
|
mkSingleRegexRule name pattern token = Types.Rule
|
|
{ Types.name = name
|
|
, Types.pattern = [regex pattern]
|
|
, Types.prod = const token
|
|
}
|
|
|
|
mkRuleInstants :: [(Text, TG.Grain, Int, String)] -> [Rule]
|
|
mkRuleInstants = map go
|
|
where
|
|
go (name, grain, n, pattern) = mkSingleRegexRule name pattern $ tt $
|
|
cycleNth grain n
|
|
|
|
mkRuleDaysOfWeek :: [(Text, String)] -> [Rule]
|
|
mkRuleDaysOfWeek daysOfWeek = zipWith go daysOfWeek [1..7]
|
|
where
|
|
go (name, pattern) i =
|
|
mkSingleRegexRule name pattern $ tt $ mkOkForThisNext $ dayOfWeek i
|
|
|
|
mkRuleDaysOfWeekLatent :: [(Text, String)] -> [Rule]
|
|
mkRuleDaysOfWeekLatent daysOfWeek = zipWith go daysOfWeek [1..7]
|
|
where
|
|
go (name, pattern) i =
|
|
mkSingleRegexRule name pattern $ tt $ mkLatent $ mkOkForThisNext $ dayOfWeek i
|
|
|
|
mkRuleMonths :: [(Text, String)] -> [Rule]
|
|
mkRuleMonths = mkRuleMonthsWithLatent . map (uncurry (,, False))
|
|
|
|
mkRuleMonthsWithLatent :: [(Text, String, Bool)] -> [Rule]
|
|
mkRuleMonthsWithLatent months = zipWith go months [1..12]
|
|
where
|
|
go (name, pattern, latent) i =
|
|
mkSingleRegexRule name pattern $ tt $ (if latent then mkLatent else id)
|
|
$ mkOkForThisNext $ month i
|
|
|
|
mkRuleSeasons :: [(Text, String, TimeData, TimeData)] -> [Rule]
|
|
mkRuleSeasons = map go
|
|
where
|
|
go (name, pattern, start, end) = mkSingleRegexRule name pattern $
|
|
Token Time <$> mkOkForThisNext <$> interval TTime.Open start end
|
|
|
|
mkRuleHolidays :: [(Text, String, TimeData)] -> [Rule]
|
|
mkRuleHolidays = map go
|
|
where
|
|
go (name, pattern, td) = mkSingleRegexRule name pattern $ tt
|
|
$ withHoliday name $ mkOkForThisNext td
|
|
|
|
mkRuleHolidays' :: [(Text, String, Maybe TimeData)] -> [Rule]
|
|
mkRuleHolidays' = map go
|
|
where
|
|
go (name, pattern, maybeTimeData) = mkSingleRegexRule name pattern $ do
|
|
timeData <- maybeTimeData
|
|
tt $ withHoliday name $ mkOkForThisNext timeData
|