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