Feature completion

1 files changed, 88 insertions, 19 deletions

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?