From b6e867c227f77ea27e3c04efdb5882c629034176 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 21 Feb 2017 22:32:23 +0100 Subject: Feature completion --- lib/Postdelay/TimeSpec.hs | 107 ++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 88 insertions(+), 19 deletions(-) (limited to 'lib/Postdelay') diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs index c2ddc3f..21c48a4 100644 --- a/lib/Postdelay/TimeSpec.hs +++ b/lib/Postdelay/TimeSpec.hs @@ -48,15 +48,14 @@ weekDate :: Dateable t => Lens' t (Integer, Int, Int) weekDate = date . iso toWeekDate (\(y, w, d) -> fromWeekDate y w d) shiftBack :: (MonadReader LocalTime m, MonadWriter (PrioEndo ModPrio LocalTime) m) - => Time -> PrioEndo ModPrio LocalTime -> m () -shiftBack by mod@(view (prioEndo._Endo) -> modE) = do - tell mod - + => Time -> m a -> m a +shiftBack by mod = do + (result, modE) <- listen mod prev <- ask - new <- asks modE - case new <= prev of - True -> scribe (prio Shift) . Just . Endo $ flexDT.seconds' %~ ((^+^) by) - False -> return () + new <- asks $ view (prioEndo._Endo) modE + when (new <= prev) $ + scribe (prio Shift) . Just . Endo $ flexDT.seconds' %~ ((^+^) by) + return result timeSpec :: forall s m. StringParser s m => m (Endo LocalTime) timeSpec = label "Relative time specification" $ view prioEndo <$> choice @@ -65,8 +64,8 @@ timeSpec = label "Relative time specification" $ view prioEndo <$> choice , offsets False ] where - specBase = toEndo <$> mkGramSepBy spaces [ timeOfDay - , dateSpec + specBase = toEndo <$> mkGramSepBy spaces [ dateSpec + , timeOfDay ] toEndo :: [RWS LocalTime (PrioEndo ModPrio LocalTime) () ()] -> PrioEndo ModPrio LocalTime @@ -102,34 +101,104 @@ timeOfDay = label "Time of day" $ withShift <$> choice second pad = label "Second" . boundedRational pad $ 0 <=..< 61 withShift :: TimeOfDay -> RWS LocalTime (PrioEndo ModPrio LocalTime) () () - withShift = shiftBack (1 % Day) . mod' Assign time - mod' priority setter val = mempty & prio priority .~ (Just . Endo $ set setter val) + withShift tod = shiftBack (1 % Day) $ scribe (prio' Assign . time) tod -dateSpec = label "Date" $ choice +dateSpec = label "Date" $ (>> scribe (prio' Default . time) midnight) <$> choice [ (scribe (prio' Assign . date) =<< view date) <$ string' "today" , (scribe (prio' Assign . date) =<< views date succ) <$ string' "tomorrow" - , do + , try $ do string' "next" spaces choice [ string' "day" $> do scribe (prio' Assign . flexDT.date.days) =<< views (date.days) succ - scribe (prio' Default . time) midnight , string' "week" $> do scribe (prio' Assign . flexDT.date.days) =<< views (date.days) (+ 7) scribe (prio' Assign . weekDate._3) 1 - scribe (prio' Default . time) midnight , string' "month" $> do scribe (prio' Assign . flexDT.date.months) =<< views (date.months) succ scribe (prio' Assign . date.days) 1 - scribe (prio' Default . time) midnight , string' "year" $> do scribe (prio' Assign . flexDT.date.years) =<< views (date.years) succ scribe (prio' Assign . date.months) 1 scribe (prio' Assign . date.days) 1 - scribe (prio' Default . time) midnight ] - ] + , try $ do + let daySuffix = optional $ choice [ string' "st", string' "nd", string' "rd", string' "th" ] + (m, d) <- choice [ try $ (,) <$> monthName <* spaces <*> dayNumber False <* daySuffix + , try $ flip (,) <$> dayNumber False <* daySuffix <* spaces <*> monthName + ] + y <- optional . try $ do + spaces + optional . lexeme $ char ',' + yearNumber <* lookAhead (spaces <|> eof) + return $ scribeDate y m d + , try $ do + m <- monthNumber False + char '/' + d <- dayNumber False + y <- optional . try $ char '/' *> yearNumber <* lookAhead (spaces <|> eof) + return $ scribeDate y m d + , try $ do + d <- dayNumber False + char '.' + m <- monthNumber False + y <- optional . try $ char '.' *> yearNumber <* lookAhead (spaces <|> eof) + return $ scribeDate y m d + , try $ do + (Just -> y) <- yearNumber + char '-' + m <- monthNumber True + char '-' + d <- dayNumber True + return $ scribeDate y m d + , try $ do + ds <- lookAhead $ length <$ (optional $ ($ ()) <$> sign) <*> some digitChar + let yDs = ds - 2 {- month-} - 2 {- day -} + when (yDs <= 0) $ + fail "Too few digits to interpret as concatenated date" + (Just -> y) <- optSigned . boundedNatural True $ 10^(pred yDs) <=..< 10^yDs + m <- monthNumber True + d <- dayNumber True + return $ scribeDate y m d + , monthName <$$> \m -> shiftBack (1 % Year) $ do + scribe (prio' Assign . flexDT.date.months) m + scribe (prio' Assign . flexDT.date.days) 1 + , weekdayName <$$> \w -> shiftBack (1 % Week) $ do + scribe (prio' Assign . weekDate._3) w + ] + where + withYear y + | Just y' <- y = (>>) $ scribe (prio' Assign . date.years) y' + | otherwise = shiftBack (1 % Year) + scribeDate y m d = withYear y $ do + scribe (prio' Assign . date.months) m + scribe (prio' Assign . flexDT.date.days) d + (<$$>) = flip (<$>) + monthName = choice $ zipWith (<$) [1..] [ string' "january" <|> string' "jan" + , string' "febuary" <|> string' "feb" + , string' "march" <|> string' "mar" + , string' "april" <|> string' "apr" + , string' "may" + , string' "june" <|> string' "jun" + , string' "july" <|> string' "jul" + , string' "august" <|> string' "aug" + , string' "september" <|> string' "sep" + , string' "october" <|> string' "oct" + , string' "november" <|> string' "nov" + , string' "december" <|> string' "dec" + ] + weekdayName = choice $ zipWith (<$) [1..] [ string' "monday" <|> string' "mon" + , string' "tuesday" <|> string' "tue" + , string' "wednesday" <|> string' "wed" + , string' "thursday" <|> string' "thu" + , string' "friday" <|> string' "fri" + , string' "saturday" <|> string' "sat" + , string' "sunday" <|> string' "sun" + ] + dayNumber p = boundedNatural p (1 <=..<= 31) + monthNumber p = boundedNatural p (1 <=..<= 12) + yearNumber = optSigned $ boundedNatural False (0 <=..< PosInf) offsets :: forall s m. StringParser s m => Bool -- ^ Require sign on first offset? -- cgit v1.2.3