From 4343e02ca8431e61e2dc1755d1288dd6c55c9a23 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 16 Feb 2017 19:03:30 +0100 Subject: Bounded numeric parsers --- lib/Postdelay/TimeSpec.hs | 7 ++++- lib/Postdelay/TimeSpec/Units.hs | 9 +----- lib/Postdelay/TimeSpec/Utils.hs | 69 ++++++++++++++++++++++++++++++++++++++++- 3 files changed, 75 insertions(+), 10 deletions(-) (limited to 'lib') 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' -- cgit v1.2.3