Purely relative time specifications

5 files changed, 64 insertions, 26 deletions

diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs
index 5c41180..03baf85 100644
--- a/lib/Postdelay/TimeSpec.hs
+++ b/lib/Postdelay/TimeSpec.hs
@@ -14,16 +14,38 @@ import Text.Megaparsec
 
 import Control.Monad.IO.Class
 import Control.Applicative
+import Control.Lens hiding ((#))
 
-import Data.Semigroup
+import Data.Bool
+import Data.Semigroup hiding (option)
 import Data.Monoid (Endo(..))
+import Data.Foldable
+import Data.VectorSpace
 
 import Data.Time
+import Data.Time.Lens
 import Data.Time.Zones
 
 
+seconds' :: Timeable t => Lens' t Time
+seconds' = seconds . iso (% Second) (# Second)
+
+
 pTimeSpec :: StringParser s m => m (Endo LocalTime)
-pTimeSpec = empty
+pTimeSpec = label "Relative time specification" $
+            choice [ pOffsets False
+                   ]
+
+pOffsets :: forall s m. StringParser s m
+         => Bool -- ^ Require sign on first offset?
+         -> m (Endo LocalTime)
+pOffsets (bool optSigned signed -> reqSgn) = fmap fold $ (:) <$> offset reqSgn <*> many (offset optSigned)
+  where
+    asOffset :: Time -> Endo LocalTime
+    asOffset by = Endo $ flexDT.seconds' %~ (^+^ by)
+    offset :: (m Time -> m Time) -> m (Endo LocalTime)
+    offset sgn = asOffset <$> lexeme (sgn timeLength) <?> "Time offset"
 
 pTimeZone :: (StringParser s m, MonadIO m) => m (Either TimeZone TZ)
-pTimeZone = empty
+pTimeZone = label "Timezone" $
+            empty
diff --git a/lib/Postdelay/TimeSpec/Units.hs b/lib/Postdelay/TimeSpec/Units.hs
index 330997a..0062460 100644
--- a/lib/Postdelay/TimeSpec/Units.hs
+++ b/lib/Postdelay/TimeSpec/Units.hs
@@ -1,19 +1,21 @@
-{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, RankNTypes, DataKinds, ViewPatterns, ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell, GADTs, RankNTypes, DataKinds, ViewPatterns, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, UndecidableInstances, TypeFamilies #-}
 
 module Postdelay.TimeSpec.Units
   ( Time
   
-  , Second, Minute, Hour
-  , Day, Week, Month, Year
+  , Second(..), Minute(..), Hour(..)
+  , Day(..), Week(..), Month(..), Year(..)
 
   , timeLength
 
+  , module Data.Metrology
   , module Data.Units.SI.Prefixes
   ) where
 
 import Postdelay.TimeSpec.Utils
 
 import Control.Applicative
+import Control.Monad
 
 import Data.Metrology
 import Data.Metrology.TH
@@ -42,9 +44,6 @@ declareDerivedUnit "Year"  [t| Day  |] 365.25 Nothing
 
 type Time = MkQu_DLN D.Time DefaultLCSU Fixed.Pico
 
-data Prefix where
-  Prefix :: forall p. (UnitPrefix p, Show p) => p -> Prefix
-
 instance HasResolution p => AdditiveGroup (Fixed p) where
   zeroV = 0
   (^+^) = (+)
@@ -57,16 +56,16 @@ instance HasResolution p => VectorSpace (Fixed p) where
 
 
 timeLength :: StringParser s m => m Time
-timeLength = (*^) <$> lexeme rational <*> timeUnit
+timeLength = (*^) <$> lexeme rational <*> timeUnit <?> "Length of time"
 
 rational :: forall s m n. (StringParser s m, Fractional n, Num n) => m n
-rational = combine <$> some digitChar <*> option [] (char '.' *> many digitChar)
+rational = combine <$> some digitChar <*> option [] (char '.' *> many digitChar) <?> "Decimal number"
   where
     combine :: [Char] -> [Char] -> n
     combine (map asN -> whole) (map asN -> fractional)
       = foldl' (\i l -> i * 10 + l) 0 whole + (foldr' (\h t -> h + t / 10) 0 fractional) / 10
     asN :: Char -> n
-    asN c = fromIntegral $ ((-) `on` fromEnum) c '0'
+    asN c = fromIntegral $ fromEnum c - fromEnum '0'
 
 timeUnit :: StringParser s m => m Time
 timeUnit = label "Unit of time" . choice $
@@ -95,15 +94,28 @@ timeUnit = label "Unit of time" . choice $
            , 1 % Year   <$ choice [ string' "years"
                                   , string' "year"
                                   ]
-           ] ++
-           [ (% Second) <$> option 1 siPrefix <* string "s"
-           , (% Hour) <$> option 1 siPrefix <* string "h"
-           , (% Day) <$> option 1 siPrefix <* string "d"
-           , (% Year) <$> option 1 siPrefix <* choice [ string "a", string "yr", string "yrs" ]
+           , option 1 siPrefix <**> choice [ (% Second) <$ string "s"
+                                           , (% Hour  ) <$ string "h"
+                                           , (% Day   ) <$ string "d"
+                                           , (% Year  ) <$ choice [ string "a", string' "yr", string' "yrs" ]
+                                           ]
            ]
 
+
+data Prefix where
+  Prefix :: forall p. ParseablePrefix p => p -> Prefix
+
+class UnitPrefix a => ParseablePrefix a where
+  parser :: StringParser s m => a -> m ()
+
+instance {-# OVERLAPPABLE #-} (UnitPrefix a, Show a) => ParseablePrefix a where
+  parser = void . string . show
+
+instance ParseablePrefix Micro where
+  parser _ = void $ choice [ string "µ", string "u" ]
+
 siPrefix :: (StringParser s m, Fractional n) => m n
-siPrefix = label "SI prefix" . choice $ map (\(Prefix p) -> multiplier p <$ string (show p))
+siPrefix = label "SI prefix" . choice $ map (\(Prefix p) -> multiplier p <$ parser p)
            [ Prefix Deca, Prefix Hecto, Prefix Kilo, Prefix Mega, Prefix Giga
            , Prefix Tera, Prefix Peta, Prefix Exa, Prefix Zetta, Prefix Yotta
            , Prefix Deci, Prefix Centi, Prefix Milli, Prefix Micro, Prefix Nano
diff --git a/lib/Postdelay/TimeSpec/Utils.hs b/lib/Postdelay/TimeSpec/Utils.hs
index e4ba732..85ac299 100644
--- a/lib/Postdelay/TimeSpec/Utils.hs
+++ b/lib/Postdelay/TimeSpec/Utils.hs
@@ -7,8 +7,10 @@ import Control.Monad
 import Control.Lens
 
 import Data.Time
+import Data.Time.Lens
 import Data.Time.Zones
 
+import Data.Functor
 import Data.AdditiveGroup
 
 import Text.Megaparsec
@@ -30,6 +32,6 @@ signed = (<*>) (lexeme sign)
 optSigned = (<*>) (option id $ lexeme sign)
 
 sign :: (StringParser s m, AdditiveGroup n) => m (n -> n)
-sign = choice [ id <$ char '+'
-              , negateV <$ char '-'
-              ]
+sign = label "sign" $ choice [ char '+' $> id
+                             , char '-' $> negateV
+                             ]
diff --git a/postdelay.cabal b/postdelay.cabal
index 2e66ace..6d4323a 100644
--- a/postdelay.cabal
+++ b/postdelay.cabal
@@ -36,6 +36,8 @@ library
                      , units >=2.4 && <3
                      , units-defs >=2.0 && <3
                      , exceptions >=0.8 && <1
+                     , lens >=4.15 && <5
+                     , lens-datetime >=0.3 && <1
   hs-source-dirs:      lib
   default-language:    Haskell2010
 
diff --git a/postdelay.nix b/postdelay.nix
index 3bd6184..938557f 100644
--- a/postdelay.nix
+++ b/postdelay.nix
@@ -1,6 +1,6 @@
-{ mkDerivation, base, case-insensitive, exceptions, hsemail, list-t
-, megaparsec, mime, mtl, old-time, parsec, stdenv, time
-, transformers, tz, units, units-defs
+{ mkDerivation, base, case-insensitive, exceptions, hsemail, lens
+, lens-datetime, list-t, megaparsec, mime, mtl, old-time, parsec
+, stdenv, time, transformers, tz, units, units-defs
 }:
 mkDerivation {
   pname = "postdelay";
@@ -9,8 +9,8 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    base case-insensitive exceptions hsemail list-t megaparsec mime mtl
-    old-time parsec time tz units units-defs
+    base case-insensitive exceptions hsemail lens lens-datetime list-t
+    megaparsec mime mtl old-time parsec time tz units units-defs
   ];
   executableHaskellDepends = [ base transformers ];
   homepage = "https://git.yggdrasil.li/gkleen/pub/postdelay";