Bounded numeric parsers

5 files changed, 83 insertions, 15 deletions

diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs
index 384de4b..edd70c1 100644
--- a/lib/Postdelay/TimeSpec.hs
+++ b/lib/Postdelay/TimeSpec.hs
@@ -56,13 +56,18 @@ timeSpec = label "Relative time specification" $
                                              ]
     
     toEndo :: [RWS LocalTime () LocalTime a] -> Endo LocalTime
-    toEndo acts = Endo $ \t -> fst $ execRWS (sequence acts) t t
+    toEndo (sequence -> act) = Endo $ \t -> fst $ execRWS act t t
 
 timeOfDay, dateSpec :: StringParser s m => m (RWS LocalTime () LocalTime ())
 timeOfDay = label "Time of day" $ shiftBack (1 % Day) . assign time <$> choice
             [ TimeOfDay 0  0 0 <$ string' "midnight"
             , TimeOfDay 12 0 0 <$ string' "noon"
             , TimeOfDay 16 0 0 <$ string' "teatime"
+            , try $ do
+                h <- boundedNatural True $ 0 <=..<= 24
+                m <- boundedNatural True $ 0 <=..<= 59
+                s <- option 0 $ boundedRational True $ 0 <=..< 61
+                return $ TimeOfDay h m s
             ]
 dateSpec = label "Date" $ (date <~) <$> choice
            [ view date <$ string' "today"
diff --git a/lib/Postdelay/TimeSpec/Units.hs b/lib/Postdelay/TimeSpec/Units.hs
index a094ea3..4874ce9 100644
--- a/lib/Postdelay/TimeSpec/Units.hs
+++ b/lib/Postdelay/TimeSpec/Units.hs
@@ -56,14 +56,7 @@ instance HasResolution p => VectorSpace (Fixed p) where
 
 
 timeLength :: StringParser s m => m Time
-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) <?> "Decimal number"
-  where
-    combine :: [Char] -> [Char] -> n
-    combine (map fromDigit -> whole) (map fromDigit -> fractional)
-      = foldl' (\i l -> i * 10 + l) 0 whole + (foldr' (\h t -> h + t / 10) 0 fractional) / 10
+timeLength = (*^) <$> lexeme (boundedRational False $ 0 <=..< PosInf) <*> timeUnit <?> "Length of time"
 
 timeUnit :: StringParser s m => m Time
 timeUnit = label "Unit of time" . choice $
diff --git a/lib/Postdelay/TimeSpec/Utils.hs b/lib/Postdelay/TimeSpec/Utils.hs
index 54b85f7..c10fc4b 100644
--- a/lib/Postdelay/TimeSpec/Utils.hs
+++ b/lib/Postdelay/TimeSpec/Utils.hs
@@ -1,6 +1,17 @@
 {-# LANGUAGE RankNTypes, ConstraintKinds, TypeFamilies, FlexibleContexts, ScopedTypeVariables, ViewPatterns, TupleSections #-}
 
-module Postdelay.TimeSpec.Utils where
+module Postdelay.TimeSpec.Utils
+  ( StringParser
+  , spaceConsumer, spaces
+  , lexeme
+  , signed, optSigned
+  , sign
+  , boundedNatural
+  , boundedRational
+  , module Data.Interval
+  , fromDigit
+  , mkGramSepBy
+  ) where
 
 import Control.Applicative
 import Control.Monad
@@ -10,8 +21,13 @@ import Data.Time
 import Data.Time.Lens
 import Data.Time.Zones
 
+import Data.Bool
+import Data.Foldable
 import Data.Functor
+import Data.Function
 import Data.AdditiveGroup
+import Data.Interval (Interval, Extended(..), (<=..<=), (<=..<), (<..<=), (<..<), interval)
+import qualified Data.Interval as I
 
 import Text.Megaparsec
 import Text.Megaparsec.Prim (MonadParsec)
@@ -37,6 +53,57 @@ sign = label "sign" $ choice [ char '+' $> id
                              , char '-' $> negateV
                              ]
 
+boundedNatural :: forall s n m. (Show n, Real n, StringParser s m)
+               => Bool -- ^ Require number to be padded with zeroes?
+               -> Interval n -> m n
+boundedNatural padded (I.intersection (0 <=..< PosInf) -> bounds) = do
+  n <- foldl' (\i l -> i * 10 + l) 0 <$> digitN (fromDigit <$> digitChar) <?> "Natural number cotained in: " ++ show bounds
+  when (not $ n `I.member` bounds) $ fail "Natural number out of bounds"
+  return n
+  where
+    digitN :: m n -> m [n]
+    digitN p
+      | PosInf <- maxDigits
+      , Finite min <- minDigits = (++) <$> count min p <*> many p
+      | Finite max <- maxDigits
+      , Finite min <- minDigits
+      , not padded = count' min max p
+      | Finite max <- maxDigits
+      , Finite _ <- minDigits
+      , padded = count max p
+      | otherwise = error "boundedNatural in undefined state"
+
+    minDigits, maxDigits :: Extended Int
+    (minDigits, maxDigits) = ( fmap digits . I.lowerBound $ close bounds
+                             , fmap digits . I.upperBound $ close bounds
+                             )
+      where
+        close int
+          | (Finite min, False) <- I.lowerBound' int = close $ interval (Finite $ min + 1, True) (I.upperBound' int)
+          | (Finite max, False) <- I.upperBound' int = close $ interval (I.lowerBound' int) (Finite $ max - 1, True)
+          | otherwise = int
+
+    digits :: n -> Int
+    digits = ceiling . (logBase 10 :: Double -> Double) . realToFrac . abs
+
+boundedRational :: forall s m n. (Show n, RealFrac n, StringParser s m)
+                => Bool -- ^ Require number to be padded with zeroes
+                -> Interval n -> m n
+boundedRational padded (I.intersection (0 <=..< PosInf) -> bounds)
+  = (+) <$> boundedNatural padded wholeBounds <*> fractional <?> "Nonnegative real contained in: " ++ show bounds
+  where
+    fractional :: m n
+    fractional = reqFractional $ char '.' $> (/ 10) . foldr' (\h t -> h + t / 10) 0 <*> some (fromDigit <$> digitChar)
+    
+    reqFractional
+      | contained = option 0
+      | otherwise = id
+      where (_, contained) = I.lowerBound' bounds
+    wholeBounds
+      | (Finite max, False) <- I.upperBound' bounds
+      , max == (fromInteger $ round max) = interval (I.lowerBound' bounds) (Finite $ max - 1, True)
+      | otherwise = bounds
+
 fromDigit :: Num n => Char -> n
 fromDigit c = fromIntegral $ fromEnum c - fromEnum '0'
 
diff --git a/postdelay.cabal b/postdelay.cabal
index 6d4323a..b184ce4 100644
--- a/postdelay.cabal
+++ b/postdelay.cabal
@@ -38,6 +38,7 @@ library
                      , exceptions >=0.8 && <1
                      , lens >=4.15 && <5
                      , lens-datetime >=0.3 && <1
+                     , data-interval >=1.2 && <2
   hs-source-dirs:      lib
   default-language:    Haskell2010
 
diff --git a/postdelay.nix b/postdelay.nix
index 938557f..4c1dca6 100644
--- a/postdelay.nix
+++ b/postdelay.nix
@@ -1,6 +1,7 @@
-{ 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, base, case-insensitive, data-interval, 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 +10,9 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    base case-insensitive exceptions hsemail lens lens-datetime list-t
-    megaparsec mime mtl old-time parsec time tz units units-defs
+    base case-insensitive data-interval 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";