diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,9 +1,22 @@ +Version 0.2.0 + +* Incompatible API change to cleanup some initial design decisions: + the two level `FormatOption`/`FormatMode` model is removed, the + fixed unit of `FormatOption` is moved to a new constructor + `FormatMode`, and `FormatOption` is removed entirely. This should be + a simpler API, at the cost of breaking compatibility. +* Fixed issue #3 (No support for negative numbers). +* Worked around issue #1 (Add 'base' unit) by adding a mode that + disables scaling; it should have the same effect without introducing + an artificial unit. + Version 0.1.0.2 * Trivial release for compatibility with QuickCheck 2.7 and older HUnit packages as found in Wheezy. * The release switches the test suite to use Cabal macros, which might create issues in some cases. +* Fixed issue #2 (Wrong formatting for small numbers in SI mode). Version 0.1.0.1 diff --git a/Data/Prefix/Units.hs b/Data/Prefix/Units.hs --- a/Data/Prefix/Units.hs +++ b/Data/Prefix/Units.hs @@ -1,6 +1,6 @@ {- -Copyright 2012, 2014, Google Inc. +Copyright 2012, 2014, 2015, Google Inc. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -66,11 +66,11 @@ A few examples are given below: ->>> showValue (Left FormatBinary) 2048 +>>> showValue FormatBinary 2048 "2.0Ki" ->>> showValue (Left FormatSiAll) 0.0001 +>>> showValue FormatSiAll 0.0001 "100.0u" ->>> showValue (Right Mebi) 1048576 +>>> showValue (FormatFixed Mebi) 1048576 "1Mi" >>> parseValue ParseExact "2.5Ki"::Either String Double Right 2560.0 @@ -94,6 +94,8 @@ , siSupraunitary , siKMGT , binaryUnits + , siBase + , binaryBase -- ** Unit-related functions , unitMultiplier , unitName @@ -120,11 +122,11 @@ , showValueWith ) where -import Control.Monad.Instances () +import Control.Monad (liftM) import Data.Char (toUpper) import Data.List (intercalate) ---import Data.Prefix.Units.Helpers +import Data.Prefix.Units.Compat () default () @@ -176,6 +178,14 @@ siKMGT :: [Unit] siKMGT = filter (>= Kilo) siUnits +-- | The base for SI units. +siBase :: Rational +siBase = 10 + +-- | The base for binary units. +binaryBase :: Rational +binaryBase = 2 + -- | Returns the unit scaling \"multiplier\" (which can be either -- supra- or sub-unitary): -- @@ -184,32 +194,32 @@ -- >>> unitMultiplier Mebi -- 1048576 % 1 unitMultiplier :: Unit -> Rational -unitMultiplier Yocto = 10.0 ^^ (-24 :: Int) -unitMultiplier Zepto = 10.0 ^^ (-21 :: Int) -unitMultiplier Atto = 10.0 ^^ (-18 :: Int) -unitMultiplier Femto = 10.0 ^^ (-15 :: Int) -unitMultiplier Pico = 10.0 ^^ (-12 :: Int) -unitMultiplier Nano = 10.0 ^^ ( -9 :: Int) -unitMultiplier Micro = 10.0 ^^ ( -6 :: Int) -unitMultiplier Milli = 10.0 ^^ ( -3 :: Int) -unitMultiplier Centi = 10.0 ^^ ( -2 :: Int) -unitMultiplier Deci = 10.0 ^^ ( -1 :: Int) -unitMultiplier Deka = 10.0 ^^ ( 1 :: Int) -unitMultiplier Hecto = 10.0 ^^ ( 2 :: Int) -unitMultiplier Kilo = 10.0 ^^ ( 3 :: Int) -unitMultiplier Kibi = 2.0 ^^ ( 10 :: Int) -unitMultiplier Mega = 10.0 ^^ ( 6 :: Int) -unitMultiplier Mebi = 2.0 ^^ ( 20 :: Int) -unitMultiplier Giga = 10.0 ^^ ( 9 :: Int) -unitMultiplier Gibi = 2.0 ^^ ( 30 :: Int) -unitMultiplier Tera = 10.0 ^^ ( 12 :: Int) -unitMultiplier Tebi = 2.0 ^^ ( 40 :: Int) -unitMultiplier Peta = 10.0 ^^ ( 15 :: Int) -unitMultiplier Pebi = 2.0 ^^ ( 50 :: Int) -unitMultiplier Exa = 10.0 ^^ ( 18 :: Int) -unitMultiplier Exbi = 2.0 ^^ ( 60 :: Int) -unitMultiplier Zetta = 10.0 ^^ ( 21 :: Int) -unitMultiplier Yotta = 10.0 ^^ ( 24 :: Int) +unitMultiplier Yocto = siBase ^^ (-24 :: Int) +unitMultiplier Zepto = siBase ^^ (-21 :: Int) +unitMultiplier Atto = siBase ^^ (-18 :: Int) +unitMultiplier Femto = siBase ^^ (-15 :: Int) +unitMultiplier Pico = siBase ^^ (-12 :: Int) +unitMultiplier Nano = siBase ^^ ( -9 :: Int) +unitMultiplier Micro = siBase ^^ ( -6 :: Int) +unitMultiplier Milli = siBase ^^ ( -3 :: Int) +unitMultiplier Centi = siBase ^^ ( -2 :: Int) +unitMultiplier Deci = siBase ^^ ( -1 :: Int) +unitMultiplier Deka = siBase ^^ ( 1 :: Int) +unitMultiplier Hecto = siBase ^^ ( 2 :: Int) +unitMultiplier Kilo = siBase ^^ ( 3 :: Int) +unitMultiplier Kibi = binaryBase ^^ ( 10 :: Int) +unitMultiplier Mega = siBase ^^ ( 6 :: Int) +unitMultiplier Mebi = binaryBase ^^ ( 20 :: Int) +unitMultiplier Giga = siBase ^^ ( 9 :: Int) +unitMultiplier Gibi = binaryBase ^^ ( 30 :: Int) +unitMultiplier Tera = siBase ^^ ( 12 :: Int) +unitMultiplier Tebi = binaryBase ^^ ( 40 :: Int) +unitMultiplier Peta = siBase ^^ ( 15 :: Int) +unitMultiplier Pebi = binaryBase ^^ ( 50 :: Int) +unitMultiplier Exa = siBase ^^ ( 18 :: Int) +unitMultiplier Exbi = binaryBase ^^ ( 60 :: Int) +unitMultiplier Zetta = siBase ^^ ( 21 :: Int) +unitMultiplier Yotta = siBase ^^ ( 24 :: Int) -- | Returns the unit full name. unitName :: Unit -> String @@ -315,47 +325,61 @@ | FormatSiSupraunitary -- ^ Formats the value using supraunitary SI -- units only (which means that e.g. @0.001@ -- will remain as such instead of being - -- formatted as @1m@) + -- formatted as @1m@). | FormatSiKMGT -- ^ Formats the value using units greater or -- equal to 'Kilo'. | FormatBinary -- ^ Formats the value using binary units. - deriving (Show, Enum, Bounded) - --- | Type synonym to choose between a 'FormatMode' or a 'Unit'. -type FormatOption = Either FormatMode Unit + | FormatUnscaled -- ^ Formats the value as it is, without + -- scaling. + | FormatFixed Unit -- ^ Formats the value using the given unit. + deriving (Show) -- | The available units range for various format modes. -unitRange :: FormatMode -> [Unit] -unitRange FormatSiAll = siUnits -unitRange FormatSiSupraunitary = siSupraunitary -unitRange FormatSiKMGT = siKMGT -unitRange FormatBinary = binaryUnits +unitRange :: FormatMode -> Either Unit [Unit] +unitRange FormatSiAll = Right siUnits +unitRange FormatSiSupraunitary = Right siSupraunitary +unitRange FormatSiKMGT = Right siKMGT +unitRange FormatBinary = Right binaryUnits +unitRange FormatUnscaled = Right [] +unitRange (FormatFixed u) = Left u +-- | Whether a given value should be scaled (in auto-scaling modes) or +-- not. +shouldScale :: (Num a, Ord a) => a -> Bool +-- FIXME: this is not nice at all: we hardcode the set [1, 10) instead +-- of having it naturally follow from a base unit or similar. +shouldScale val = val < 1 || val >= 10 + -- | Computes the recommended unit for displaying a given value. The -- simple algorithm uses the first unit for which we have a -- supraunitary representation. In case we don't find any such value --- (e.g. for a zero value), then 'Nothing' is returned. +-- (e.g. for a zero value), then 'Nothing' is returned. For +-- `FormatFixed`, we always select the given unit, irrespective of the +-- value. recommendedUnit :: (Real a) => FormatMode -> a -> Maybe Unit -recommendedUnit fmt val - -- FIXME: this is not nice at all: we hardcode the set [1, 10) - -- instead of having it naturally follow from a base unit or - -- similar. - | val >= 1 && val < 10 = Nothing - | otherwise = - let range = unitRange fmt - ratv = Prelude.toRational val - in foldr (\u a -> if ratv / unitMultiplier u >= 1 then Just u else a) - Nothing $ reverse range +recommendedUnit fmt val = + case unitRange fmt of + Left u -> Just u + Right range -> + if shouldScale val + then foldr (\u a -> if ratv / unitMultiplier u >= 1 then Just u else a) + Nothing $ reverse range + else Nothing + where ratv = Prelude.toRational val -- | Computes the scaled value and unit for a given value formatValue :: (RationalConvertible a) => - FormatOption -- ^ The desired 'FormatMode' or 'Unit' + FormatMode -- ^ The desired 'FormatMode' -> a -- ^ The value to format -> (a, Maybe Unit) -- ^ Scaled value and optional unit formatValue fmt val = - let unit = either (`recommendedUnit` val) Just fmt - scaled = maybe val (scaleToUnit val) unit - in (scaled, unit) + let inverter = if val < 0 + then negate + else id + val' = inverter val + unit = recommendedUnit fmt val' + scaled = maybe val' (scaleToUnit val') unit + in (inverter scaled, unit) -- | Simple helper to generate the full string representation of an -- integral value. @@ -364,7 +388,7 @@ -- (optional) unit into a -- string, e.g. 'unitSymbol' or -- 'fancySymbol' - -> FormatOption -- ^ The desired format mode + -> FormatMode -- ^ The desired format mode -> a -- ^ The value to show -> String -- ^ Resulting string showValueWith symbfn fmt val = @@ -373,11 +397,7 @@ -- | Generates a final string representation of a value. showValue :: (RationalConvertible a, Show a) => - FormatOption -- ^ The desired format mode, either as a - -- 'Left' 'FormatMode' value which computes - -- the unit automatically, or as a 'Right' - -- 'Unit', which will use the specified - -- unit + FormatMode -- ^ The desired format mode. -> a -- ^ The value to show -> String -- ^ Resulting string showValue = showValueWith unitSymbol @@ -518,18 +538,13 @@ -> ParseMode -> [Unit] -> String - -> Maybe (Either String Unit) -processUnit popts pmode valid_units unit_suffix = - if null unit_suffix - then case popts of - UnitRequired -> Just $ Left "An unit is required but the\ - \ input string lacks one" - UnitDefault def_unit -> Just $ Right def_unit - UnitOptional -> Nothing - else Just $ - -- this is because older GHC versions don't have the "Either - -- String a" monad instance - either Left (validUnit valid_units) (parseSymbol pmode unit_suffix) + -> Either String (Maybe Unit) +processUnit UnitRequired _ _ "" = + Left "An unit is required but the input string lacks one" +processUnit (UnitDefault u) _ _ "" = Right $ Just u +processUnit UnitOptional _ _ "" = Right Nothing +processUnit _ pmode valid_units unit_suffix = + liftM Just (parseSymbol pmode unit_suffix >>= validUnit valid_units) -- | Low-level parse routine. Takes two function arguments which fix -- the initial and final conversion, a parse mode and the string to be @@ -545,7 +560,7 @@ [(v, suffix)] -> let unit_suffix = dropWhile (== ' ') suffix unit = processUnit popts pmode valid_units unit_suffix - in maybe (Right v) (fmap (scaleFromUnit v)) unit + in maybe v (scaleFromUnit v) `fmap` unit _ -> Left $ "Can't parse string '" ++ str ++ "'" -- | Converts a string to upper-case. diff --git a/Data/Prefix/Units/Compat.hs b/Data/Prefix/Units/Compat.hs new file mode 100644 --- /dev/null +++ b/Data/Prefix/Units/Compat.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- + +Copyright 2015, Google Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above +copyright notice, this list of conditions and the following disclaimer +in the documentation and/or other materials provided with the +distribution. + * Neither the name of Google Inc. nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +-} + +{- | Definitions for compatibility across various GHC versions -} + +module Data.Prefix.Units.Compat + where + +#if !MIN_VERSION_base(4,6,0) +import Control.Monad.Instances () +#endif + +#if !MIN_VERSION_base(4,3,0) +instance Monad (Either a) where + return = Right + Left l >>= _ = Left l + Right r >>= f = f r +#endif diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -25,7 +25,9 @@ lint: @rm -f report.html - hlint --cpp-define='MIN_VERSION_QuickCheck(a,b,c)=1' \ + hlint \ + --cpp-define='MIN_VERSION_QuickCheck(a,b,c)=1' \ + --cpp-define='MIN_VERSION_base(a,b,c)=1' \ --report -c Data tests clean: diff --git a/example.hs b/example.hs new file mode 100644 --- /dev/null +++ b/example.hs @@ -0,0 +1,23 @@ +module Main where + +import Data.Prefix.Units + +showValueAs :: Double -> FormatMode -> IO () +showValueAs val mode = do + putStrLn $ "Formatting " ++ show val ++ " in mode " ++ show mode ++ + " is: " ++ showValue mode val + +main = do + putStr $ "Enter a value (with optional units; case sensitive!): " + in_str <- getLine + case parseValue ParseExact in_str of + Left err -> putStrLn $ "Error parsing the value: " ++ err + Right v -> do + putStrLn $ "You entered " ++ show v + mapM_ (showValueAs v) [ FormatSiAll + , FormatSiSupraunitary + , FormatSiKMGT + , FormatBinary + , FormatUnscaled + ] + mapM_ (showValueAs v . FormatFixed) [minBound..maxBound] diff --git a/prefix-units.cabal b/prefix-units.cabal --- a/prefix-units.cabal +++ b/prefix-units.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.1.0.2 +Version: 0.2.0 -- A short (one-line) description of the package. Synopsis: A basic library for SI/binary prefix units @@ -39,7 +39,7 @@ Maintainer: Iustin Pop -- A copyright notice. -Copyright: (c) 2012, 2014 Google Inc. +Copyright: (c) 2012, 2014, 2015 Google Inc. Category: Data @@ -52,12 +52,12 @@ -- Extra files to be distributed with the package, such as examples or -- a README. -Extra-source-files: README.md CHANGES.md Makefile +Extra-source-files: README.md CHANGES.md Makefile example.hs -- Constraint on the version of Cabal needed to build this package. Cabal-version: >= 1.8.0.2 -Tested-with: GHC==6.12.1, GHC==7.4.1, GHC==7.6.3 +Tested-with: GHC==7.6.3, GHC==7.8.4, GHC==7.10.2 Source-repository head Type: git @@ -66,7 +66,7 @@ Source-repository this Type: git Location: https://github.com/iustin/prefix-units.git - Tag: prefix-units-v0.1.0.1 + Tag: prefix-units-v0.2.0 Library -- Modules exported by the library. @@ -76,11 +76,13 @@ Build-depends: base >= 3 && < 5 -- Modules not exported by this package. - Other-modules: + Other-modules: Data.Prefix.Units.Compat GHC-Options: -Wall - Extensions: Safe TypeSynonymInstances FlexibleInstances + Extensions: Safe + TypeSynonymInstances + FlexibleInstances -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: @@ -99,3 +101,4 @@ , prefix-units ghc-options: -Wall -fno-warn-orphans Extensions: CPP + ScopedTypeVariables diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -39,6 +39,7 @@ module Main (main) where +import Control.Applicative (pure, (<$>)) import Data.Char (toUpper) import Data.List import Data.Maybe (isNothing) @@ -92,13 +93,34 @@ counterexample "Parsed wrong value: " $ toRational v' ==? toRational v * unitMultiplier unit +-- | Generates an auto-scale 'FormatMode'. +genAutoMode :: Gen FormatMode +genAutoMode = elements [ FormatSiAll + , FormatSiSupraunitary + , FormatSiKMGT + , FormatBinary + ] + + +-- | Helper to check that unitRange retuns a Right [Unit], as expected +-- (as we pass only auto-format modes). +checkedUnitRange :: FormatMode -> [Unit] +checkedUnitRange = + either (error "unitRange returned 'Left Unit'?!") id . unitRange + -- * Instances instance Arbitrary Unit where arbitrary = elements [minBound..maxBound] instance Arbitrary FormatMode where - arbitrary = elements [minBound..maxBound] + arbitrary = oneof [ pure FormatSiAll + , pure FormatSiSupraunitary + , pure FormatSiKMGT + , pure FormatBinary + , pure FormatUnscaled + , FormatFixed <$> arbitrary + ] instance Arbitrary ParseMode where arbitrary = elements [minBound..maxBound] @@ -127,13 +149,17 @@ testOrdering :: Assertion testOrdering = do - let si_mult = map unitMultiplier $ sort siUnits - bin_mult = map unitMultiplier $ sort binaryUnits - all_mult = map unitMultiplier allUnits -- no sorting here! + let si_mult = map unitMultiplier siUnits + bin_mult = map unitMultiplier binaryUnits + all_mult = map unitMultiplier allUnits sort si_mult @=? si_mult sort bin_mult @=? bin_mult sort all_mult @=? all_mult +testOrderingProp :: Unit -> Unit -> Property +testOrderingProp u1 u2 = + compare u1 u2 ==? compare (unitMultiplier u1) (unitMultiplier u2) + testSIBinary :: Assertion testSIBinary = assertBool "SI unit lists contain binary prefixes" $ @@ -141,6 +167,13 @@ null (siKMGT `intersect` binaryUnits) && null (siSupraunitary `intersect` binaryUnits) +testSISmallMultipliers :: Assertion +testSISmallMultipliers = do + let baseExp = siBase ^^ (3::Int) + mapM_ (\unit -> assertEqual ("For unit " ++ unitName unit ++ ": ") + (baseExp * unitMultiplier (pred unit)) (unitMultiplier unit)) + $ tail (filter (<= Milli) siUnits) + -- ** Parsing testNullUnitInt :: Int -> ParseMode -> Property @@ -198,26 +231,38 @@ let str = show v ++ unitSymbol unit in expectParse v unit (parseValue ParseKMGT str::Either String Integer) --- | Parsed values should be correct. +-- | Parsed integer values should be correct. testParsingInt :: Int -> Property testParsingInt v = forAll (elements (siSupraunitary ++ binaryUnits)) $ \unit -> let str = show v ++ unitSymbol unit in expectParse v unit (parseValue ParseExact str::Either String Integer) --- | Parsed values should be correct. --- --- Note that this tests floating point number equality, so it could be --- flaky. -testParsingDouble :: Unit -> Double -> Property -testParsingDouble unit d = +-- | Polymorphic helper for checking parsing. +parsingHelper :: forall a. (Show a, Read a, + RationalConvertible a, Fractional a) => + Unit -> a -> Property +parsingHelper unit d = let str = show d ++ unitSymbol unit in - case parseValue ParseExact str::Either String Double of + case parseValue ParseExact str::Either String a of Left err -> failParseUnit unit err Right d' -> counterexample ("Parsing of " ++ str ++ " failed: ") $ d' ==? fromRational (toRational d * unitMultiplier unit) --- | Parsed values should be correct. +-- | Parsed float values should be correct. +-- +-- Note that this tests floating point number equality, so it could be +-- flaky, especially as float has lower resolution than double. +testParsingFloat :: Unit -> Float -> Property +testParsingFloat = parsingHelper + +-- | Parsed double values should be correct. +-- +-- Also potentially flaky. +testParsingDouble :: Unit -> Double -> Property +testParsingDouble = parsingHelper + +-- | Parsed rational values should be correct. testParsingRational :: Unit -> Integer -> Property testParsingRational unit v = let str = show v ++ "%1" ++ unitSymbol unit in @@ -253,27 +298,42 @@ (parseGeneric UnitOptional valid ParseExact (show v ++ unitSymbol unit)::Either String Rational) +testParsingNegativePositive :: Unit -> Positive Int -> Property +testParsingNegativePositive unit (Positive val) = + let pos = show val ++ unitSymbol unit + neg = show (negate val) ++ unitSymbol unit + in case (parseValue ParseExact pos::Either String Int, + parseValue ParseExact neg::Either String Int) of + (_, Left err) -> + failParseUnit unit err + (Left err, _) -> + failParseUnit unit err + (Right vpos, Right vneg) -> vpos ==? negate vneg + -- ** Formatting -testTrivialFormattingRec :: FormatMode -> Property -testTrivialFormattingRec fmt = +testTrivialFormattingRec :: Property +testTrivialFormattingRec = + forAll genAutoMode $ \fmt -> recommendedUnit fmt (0::Int) ==? Nothing .&&. recommendedUnit fmt (0::Double) ==? Nothing -testTrivialFormattingFmt :: FormatMode -> Property -testTrivialFormattingFmt fmt = - formatValue (Left fmt) (0::Int) ==? (0, Nothing) .&&. - formatValue (Left fmt) (0::Double) ==? (0, Nothing) +testTrivialFormattingFmt :: Property +testTrivialFormattingFmt = + forAll genAutoMode $ \fmt -> + formatValue fmt (0::Int) ==? (0, Nothing) .&&. + formatValue fmt (0::Double) ==? (0, Nothing) -testTrivialFormattingShow :: FormatMode -> Property -testTrivialFormattingShow fmt = - showValue (Left fmt) (0::Int) ==? "0" .&&. - showValue (Left fmt) (0::Double) ==? show (0::Double) +testTrivialFormattingShow :: Property +testTrivialFormattingShow = + forAll genAutoMode $ \fmt -> + showValue fmt (0::Int) ==? "0" .&&. + showValue fmt (0::Double) ==? show (0::Double) testRecommend :: Property testRecommend = forAll (elements [FormatSiAll, FormatBinary]) $ \fmt -> - forAll (elements (unitRange fmt)) $ \unit -> + forAll (elements (checkedUnitRange fmt)) $ \unit -> let value = unitMultiplier unit in case recommendedUnit fmt value of Nothing -> failTest $ "Expected recommendation of unit " ++ @@ -292,24 +352,38 @@ testForceUnit :: Unit -> Rational -> Property testForceUnit unit v = - case formatValue (Right unit) v of + case formatValue (FormatFixed unit) v of (v', Just u') -> counterexample "Invalid value/unit computed" $ unit ==? u' .&&. v ==? v' * unitMultiplier unit x -> failTest $ "Invalid result from formatValue: " ++ show x +testForceNoUnit :: Rational -> Property +testForceNoUnit v = + case formatValue FormatUnscaled v of + (v', Nothing) -> counterexample "Invalid value computed" $ + v ==? v' + (_, Just u) -> failTest ("Formatted using unit '" ++ show u ++ + "' when no unit expected") + testFormatIntegral :: Property testFormatIntegral = forAll (elements [FormatSiSupraunitary, FormatBinary]) $ \fmt -> - forAll (elements (unitRange fmt)) $ \unit -> - let fmted = formatValue (Left fmt) . truncate . unitMultiplier $ unit + forAll (elements (checkedUnitRange fmt)) $ \unit -> + let fmted = formatValue fmt . truncate . unitMultiplier $ unit in fmted ==? (1::Integer, Just unit) +testFormatNegativePositive :: Positive Int -> FormatMode -> Property +testFormatNegativePositive (Positive i) mode = + let (pscaled, punit) = formatValue mode i + (nscaled, nunit) = formatValue mode (negate i) + in (pscaled, punit) ==? (negate nscaled, nunit) + testFormatFractional :: Property testFormatFractional = forAll (elements [FormatSiSupraunitary, FormatBinary]) $ \fmt -> - forAll (elements (unitRange fmt)) $ \unit -> - let fmted = formatValue (Left fmt) . unitMultiplier $ unit + forAll (elements (checkedUnitRange fmt)) $ \unit -> + let fmted = formatValue fmt . unitMultiplier $ unit in fmted ==? (1::Rational, Just unit) testShowIntegralBinary :: Property @@ -317,15 +391,25 @@ forAll (elements binaryUnits) $ \ unit -> let value = truncate (unitMultiplier unit)::Integer in counterexample ("Formatting/showing unit " ++ show unit) $ - showValue (Left FormatBinary) value ==? '1' : unitSymbol unit + showValue FormatBinary value ==? '1' : unitSymbol unit testShowRational :: Unit -> Property testShowRational unit = let fmtmode = if unit `elem` binaryUnits then FormatBinary else FormatSiAll value = unitMultiplier unit in counterexample ("Formatting/showing unit " ++ show unit) $ - showValue (Left fmtmode) value ==? "1 % 1" ++ unitSymbol unit + showValue fmtmode value ==? "1 % 1" ++ unitSymbol unit +-- ** Round-trip tests + +testRoundTripRational :: Rational -> FormatMode -> Property +testRoundTripRational val mode = + let fmted = showValue mode val in + case parseValue ParseExact fmted of + Left err -> failTest ("Failed to parse formatted strint '" ++ fmted ++ + "': " ++ err) + Right val' -> val ==? val' + -- * Test harness main :: IO () @@ -338,7 +422,9 @@ , testCase "unique symbols" testUniqueSymbols , testCase "unique fancy symbols" testUniqueFancySymbols , testCase "ordering" testOrdering + , testProperty "ordering/prop" testOrderingProp , testCase "type mixup" testSIBinary + , testCase "SI small multipliers" testSISmallMultipliers ] , testGroup "parsing" [ testProperty "null unit integral" testNullUnitInt @@ -350,24 +436,31 @@ , testProperty "symbol parsing/failure" testSymbolParsingFail , testProperty "parsing/integral-kmgt" testParsingIntKMGT , testProperty "parsing/integral" testParsingInt - , testProperty "parsing/fractional" testParsingDouble + , testProperty "parsing/fractional-float" testParsingFloat + , testProperty "parsing/fractional-double" testParsingDouble , testProperty "parsing/rational" testParsingRational , testProperty "parsing/failure" testFailParsing , testProperty "parsing/required unit" testParsingRequired , testProperty "parsing/default" testParsingDefault , testProperty "parsing/invalid-list" testParsingInvalidList , testProperty "parsing/valid-list" testParsingValidList + , testProperty "parsing negativ/positive" testParsingNegativePositive ] , testGroup "formatting" [ testProperty "trivial formatting/recommend" testTrivialFormattingRec , testProperty "trivial formatting/fmt" testTrivialFormattingFmt , testProperty "trivial formatting/show" testTrivialFormattingShow + , testProperty "negative/positive equivalence" testFormatNegativePositive , testProperty "recommend" testRecommend , testProperty "recommend small units" testRecommendSmall , testProperty "force unit" testForceUnit + , testProperty "force no unit" testForceNoUnit , testProperty "format/int" testFormatIntegral , testProperty "format/frac" testFormatFractional , testProperty "show/integral binary" testShowIntegralBinary , testProperty "show/rational" testShowRational + ] + , testGroup "round-trip" + [ testProperty "rational round-trip" testRoundTripRational ] ]