From 4343e02ca8431e61e2dc1755d1288dd6c55c9a23 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <aethoago@141.li>
Date: Thu, 16 Feb 2017 19:03:30 +0100
Subject: Bounded numeric parsers

---
 lib/Postdelay/TimeSpec/Units.hs |  9 +-----
 lib/Postdelay/TimeSpec/Utils.hs | 69 ++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 69 insertions(+), 9 deletions(-)

(limited to 'lib/Postdelay/TimeSpec')

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'
 
-- 
cgit v1.2.3