From 6cab5d804dd2f5a5bcaa74ebad2347c9581a06b8 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <aethoago@141.li>
Date: Wed, 15 Feb 2017 23:44:38 +0100
Subject: Refined framework

---
 lib/Postdelay/Scan.hs           |  2 +-
 lib/Postdelay/TimeSpec.hs       | 26 +++++++++++++++++++++++---
 lib/Postdelay/TimeSpec/Utils.hs | 22 ++++++++++++++++++++--
 3 files changed, 44 insertions(+), 6 deletions(-)

diff --git a/lib/Postdelay/Scan.hs b/lib/Postdelay/Scan.hs
index 0a265b4..7f80818 100644
--- a/lib/Postdelay/Scan.hs
+++ b/lib/Postdelay/Scan.hs
@@ -70,7 +70,7 @@ extractDelay (Message headers _) = do
       guard $ CI.mk field == "X-Timezone"
       either throwM return =<< runParserT (spaceConsumer *> lexeme timeZone <* eof) field content
     parseDelay :: Field -> m (Endo LocalTime)
-    parseDelay (OptionalField field content) = either throwM return =<< runParserT (spaceConsumer *> lexeme timeSpec <* eof) field content
+    parseDelay (OptionalField field content) = either throwM return =<< runParserT (spaceConsumer *> timeSpec <* eof) field content
 
 localT :: Either TimeZone TZ -> Iso' UTCTime LocalTime
 localT (Left tz) = iso (utcToLocalTime tz) (localTimeToUTC tz)
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?
diff --git a/lib/Postdelay/TimeSpec/Utils.hs b/lib/Postdelay/TimeSpec/Utils.hs
index 83a271d..54b85f7 100644
--- a/lib/Postdelay/TimeSpec/Utils.hs
+++ b/lib/Postdelay/TimeSpec/Utils.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes, ConstraintKinds, TypeFamilies, FlexibleContexts, ScopedTypeVariables, ViewPatterns #-}
+{-# LANGUAGE RankNTypes, ConstraintKinds, TypeFamilies, FlexibleContexts, ScopedTypeVariables, ViewPatterns, TupleSections #-}
 
 module Postdelay.TimeSpec.Utils where
 
@@ -21,8 +21,9 @@ import qualified Text.Megaparsec.Lexer as L
 type StringParser s m = (MonadParsec Dec s m, Token s ~ Char)
 
   
-spaceConsumer :: StringParser s m => m ()
+spaceConsumer, spaces :: StringParser s m => m ()
 spaceConsumer = L.space (void spaceChar) empty empty
+spaces = void $ lexeme spaceChar
 
 lexeme :: StringParser s m => m a -> m a
 lexeme = L.lexeme spaceConsumer
@@ -38,3 +39,20 @@ sign = label "sign" $ choice [ char '+' $> id
 
 fromDigit :: Num n => Char -> n
 fromDigit c = fromIntegral $ fromEnum c - fromEnum '0'
+
+mkGramSepBy :: MonadParsec e s m => m a -> [m b] -> m [b]
+mkGramSepBy sep ps = map snd <$> mkGramSepBy' sep (zip [0..] ps)
+  where
+    mkGramSepBy' _ [] = empty
+    mkGramSepBy' _ [(n, x)] = pure . (n, ) <$> x
+    mkGramSepBy' sep ps = do
+      head@(n, _) <- choice $ map (\(n, p) -> (n, ) <$> p) ps
+      let ps' = filter (\(i, _) -> i /= n) ps
+      tail <- option [] . try $ sep *> mkGramSepBy' sep ps'
+      return $ insert head tail
+
+    insert :: forall a. (Integer, a) -> [(Integer, a)] -> [(Integer, a)]
+    insert x@(fst -> a) [] = [x]
+    insert x@(fst -> a) (y@(fst -> b):ds)
+      | a <= b = x:y:ds
+      | otherwise = y:(insert x ds)
-- 
cgit v1.2.3