Refined framework

1 files changed, 23 insertions, 3 deletions

diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs
index a72f87e..8244885 100644
--- a/lib/Postdelay/TimeSpec.hs
+++ b/lib/Postdelay/TimeSpec.hs
@@ -16,7 +16,8 @@ import Control.Monad.IO.Class
 import Control.Applicative
 import Control.Lens hiding ((#))
 import Control.Exception (IOException)
-import Control.Monad.Catch
+import Control.Monad.Catch hiding (try)
+import Control.Monad.RWS hiding ((<>))
 
 import Data.Bool
 import Data.Semigroup hiding (option)
@@ -36,11 +37,30 @@ utcOffset :: Iso' TimeZone Time
 utcOffset = iso ((% Minute) . fromIntegral . timeZoneMinutes) (minutesToTimeZone . round . (# Minute))
 
 
-timeSpec :: StringParser s m => m (Endo LocalTime)
+timeSpec :: forall s m. StringParser s m => m (Endo LocalTime)
 timeSpec = label "Relative time specification" $
-           choice [ lexeme (string' "now") *> offsets True
+           choice [ flip (<>) <$> lexeme specBase <*> option mempty (offsets True)
+                  , lexeme (string' "now") *> offsets True
                   , offsets False
                   ]
+  where
+    specBase = foldMap toEndo <$> mkGramSepBy spaces [ absDate
+                                                     , timeOfDay
+                                                     ]
+    
+    toEndo :: RWS LocalTime () LocalTime a -> Endo LocalTime
+    toEndo act = Endo $ \t -> fst $ execRWS act t t
+
+timeOfDay, absDate :: StringParser s m => m (RWS LocalTime () LocalTime ())
+timeOfDay = label "Time of day" $ assign time <$> choice
+            [ TimeOfDay 0  0 0 <$ string' "midnight"
+            , TimeOfDay 12 0 0 <$ string' "noon"
+            , TimeOfDay 16 0 0 <$ string' "teatime"
+            ]
+absDate = label "Date" . (fmap . (=<<) . assign $ date) $ choice
+          [ view date <$ string' "today"
+          , views date succ <$ string' "tomorrow"
+          ]
 
 offsets :: forall s m. StringParser s m
          => Bool -- ^ Require sign on first offset?