diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,16 +1,59 @@ -Version 0.1.0.2 +## Version 0.3.0.1 +*released Thu, 27 Apr 2023* + +It turns out that even if `cabal check` shows no warnings, Hackage +doesn't accept packages with very old cabal version constraints. So +this release bumps that, which in turns makes `cabal check` actually +start to show warnings, so modernise the cabal file as a result. + +There are no code changes compared to 0.3.0, so this is a no-op +release from the point of view of functionality. + +## Version 0.3.0 + +*released Wed, 26 Apr 2023* + +* Add the new quecto/ronto/ronna/quetta units. I didn't think I'd ever + have to extend the list of units! Not sure entirely if these should + be part of the parseKMGT function, since they're high enough to be + out of normal computer units, but they do have lower/upper versions, + so adding them seems the right thing. + +## Version 0.2.0 + +*released Sun, 22 Nov 2015* + +* 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 + +*released Sun, 23 Nov 2014* + * 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 +## Version 0.1.0.1 +*released Mon, 19 May 2014* + * Trivial release updating upper package bounds (for testing), updating homepage/related settings as part of move to github, and fixing a few documentation issues. -Version 0.1.0 +## Version 0.1.0 + +*released Thu, 03 May 2012* * Initial release. 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,16 +122,18 @@ , 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 () -- | The unit type. -data Unit = Yocto +data Unit = Quecto + | Ronto + | Yocto | Zepto | Atto | Femto @@ -155,13 +159,38 @@ | Exbi | Zetta | Yotta + | Ronna + | Quetta deriving (Show, Eq, Enum, Bounded, Ord) -- | List of all SI units. siUnits :: [Unit] siUnits - = [Yocto, Zepto, Atto, Femto, Pico, Nano, Micro, Milli, Centi, - Deci, Deka, Hecto, Kilo, Mega, Giga, Tera, Peta, Exa, Zetta, Yotta] + = [ Quecto + , Ronto + , Yocto + , Zepto + , Atto + , Femto + , Pico + , Nano + , Micro + , Milli + , Centi + , Deci + , Deka + , Hecto + , Kilo + , Mega + , Giga + , Tera + , Peta + , Exa + , Zetta + , Yotta + , Ronna + , Quetta + ] -- | List of binary units. binaryUnits :: [Unit] @@ -176,6 +205,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,90 +221,102 @@ -- >>> 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 Quecto = siBase ^^ (-30 :: Int) +unitMultiplier Ronto = siBase ^^ (-27 :: 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) +unitMultiplier Ronna = siBase ^^ ( 27 :: Int) +unitMultiplier Quetta = siBase ^^ ( 30 :: Int) -- | Returns the unit full name. unitName :: Unit -> String -unitName Yocto = "yocto" -unitName Zepto = "zepto" -unitName Atto = "atto" -unitName Femto = "femto" -unitName Pico = "pico" -unitName Nano = "nano" -unitName Micro = "micro" -unitName Milli = "milli" -unitName Centi = "centi" -unitName Deci = "deci" -unitName Deka = "deka" -unitName Hecto = "hecto" -unitName Kilo = "kilo" -unitName Kibi = "kibi" -unitName Mega = "mega" -unitName Mebi = "mebi" -unitName Giga = "giga" -unitName Gibi = "gibi" -unitName Tera = "tera" -unitName Tebi = "tebi" -unitName Peta = "peta" -unitName Pebi = "pebi" -unitName Exa = "exa" -unitName Exbi = "exbi" -unitName Zetta = "zetta" -unitName Yotta = "yotta" +unitName Quecto = "quecto" +unitName Ronto = "ronto" +unitName Yocto = "yocto" +unitName Zepto = "zepto" +unitName Atto = "atto" +unitName Femto = "femto" +unitName Pico = "pico" +unitName Nano = "nano" +unitName Micro = "micro" +unitName Milli = "milli" +unitName Centi = "centi" +unitName Deci = "deci" +unitName Deka = "deka" +unitName Hecto = "hecto" +unitName Kilo = "kilo" +unitName Kibi = "kibi" +unitName Mega = "mega" +unitName Mebi = "mebi" +unitName Giga = "giga" +unitName Gibi = "gibi" +unitName Tera = "tera" +unitName Tebi = "tebi" +unitName Peta = "peta" +unitName Pebi = "pebi" +unitName Exa = "exa" +unitName Exbi = "exbi" +unitName Zetta = "zetta" +unitName Yotta = "yotta" +unitName Ronna = "ronna" +unitName Quetta = "quetta" -- | Returns the unit ASCII symbol. unitSymbol :: Unit -> String -unitSymbol Yocto = "y" -unitSymbol Zepto = "z" -unitSymbol Atto = "a" -unitSymbol Femto = "f" -unitSymbol Pico = "p" -unitSymbol Nano = "n" -unitSymbol Micro = "u" -unitSymbol Milli = "m" -unitSymbol Centi = "c" -unitSymbol Deci = "d" -unitSymbol Deka = "da" -unitSymbol Hecto = "h" -unitSymbol Kilo = "k" -unitSymbol Kibi = "Ki" -unitSymbol Mega = "M" -unitSymbol Mebi = "Mi" -unitSymbol Giga = "G" -unitSymbol Gibi = "Gi" -unitSymbol Tera = "T" -unitSymbol Tebi = "Ti" -unitSymbol Peta = "P" -unitSymbol Pebi = "Pi" -unitSymbol Exa = "E" -unitSymbol Exbi = "Ei" -unitSymbol Zetta = "Z" -unitSymbol Yotta = "Y" +unitSymbol Quecto = "q" +unitSymbol Ronto = "r" +unitSymbol Yocto = "y" +unitSymbol Zepto = "z" +unitSymbol Atto = "a" +unitSymbol Femto = "f" +unitSymbol Pico = "p" +unitSymbol Nano = "n" +unitSymbol Micro = "u" +unitSymbol Milli = "m" +unitSymbol Centi = "c" +unitSymbol Deci = "d" +unitSymbol Deka = "da" +unitSymbol Hecto = "h" +unitSymbol Kilo = "k" +unitSymbol Kibi = "Ki" +unitSymbol Mega = "M" +unitSymbol Mebi = "Mi" +unitSymbol Giga = "G" +unitSymbol Gibi = "Gi" +unitSymbol Tera = "T" +unitSymbol Tebi = "Ti" +unitSymbol Peta = "P" +unitSymbol Pebi = "Pi" +unitSymbol Exa = "E" +unitSymbol Exbi = "Ei" +unitSymbol Zetta = "Z" +unitSymbol Yotta = "Y" +unitSymbol Ronna = "R" +unitSymbol Quetta = "Q" -- | Returns the unit symbol, which for the 'Micro' unit is not ASCII. fancySymbol :: Unit -> String @@ -315,47 +364,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 +427,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 +436,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 @@ -390,6 +449,8 @@ -- | Parses a symbol in the exact mode. See 'ParseExact' for details. parseExactSymbol :: String -> Either String Unit +parseExactSymbol "q" = Right Quecto +parseExactSymbol "r" = Right Ronto parseExactSymbol "y" = Right Yocto parseExactSymbol "z" = Right Zepto parseExactSymbol "a" = Right Atto @@ -416,6 +477,8 @@ parseExactSymbol "Ei" = Right Exbi parseExactSymbol "Z" = Right Zetta parseExactSymbol "Y" = Right Yotta +parseExactSymbol "R" = Right Ronna +parseExactSymbol "Q" = Right Quetta parseExactSymbol unit = unknownUnit unit -- | Helper for 'parseBinarySymbol' which only deals with upper-case @@ -456,6 +519,8 @@ helperParseKMGT "EI" = Right Exbi helperParseKMGT "Z" = Right Zetta helperParseKMGT "Y" = Right Yotta +helperParseKMGT "R" = Right Ronna +helperParseKMGT "Q" = Right Quetta -- FIXME: error message will contain upper-case version of the symbol helperParseKMGT symbol = unknownUnit symbol @@ -518,18 +583,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 +605,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/README.md b/README.md --- a/README.md +++ b/README.md @@ -25,6 +25,9 @@ the use of some hand-coded conversions instead of using TemplateHaskell to generate them automatically. +[![GitHub Workflow Status](https://img.shields.io/github/actions/workflow/status/iustin/prefix-units/ci.yml?branch=master)](https://github.com/iustin/prefix-units/actions/workflows/ci.yml) +[![Codecov](https://img.shields.io/codecov/c/github/iustin/prefix-units)](https://codecov.io/gh/iustin/prefix-units) + TODO ---- @@ -32,7 +35,7 @@ composable. I'm still looking for a nicer way to expose the parsing functionality. -Currently, the binary and SI units are mixed in the same +Currently, the IEC (binary) and SI units are mixed in the same data-type. This works, but at some level I think two separate types would be more "correct", at the expense of a more complex API. 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 @@ -1,87 +1,100 @@ +cabal-version: 1.18 -- prefix-units.cabal auto-generated by cabal init. For additional -- options, see -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. -- The name of the package. -Name: prefix-units +name: prefix-units -- 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.3.0.1 -- A short (one-line) description of the package. -Synopsis: A basic library for SI/binary prefix units +synopsis: A basic library for SI/IEC prefix units -- A longer description of the package. -Description: +description: This library deals with parsing values containing \"prefix units\" - (both binary and SI). For example, it can parse 10M and 1G, and it - can also format values for displaying with the \"optimal\" unit. + (both IEC\/binary and SI). For example, it can parse 10M and 1G, + and it can also format values for displaying with the \"optimal\" + unit. For more details, see the man page units(7), and . -- URL for the project homepage or repository. -Homepage: https://github.com/iustin/prefix-units +homepage: https://github.com/iustin/prefix-units -- The license under which the package is released. -License: BSD3 +license: BSD3 -- The file containing the license text. -License-file: LICENSE +license-file: LICENSE -- The package author(s). -Author: Iustin Pop +author: Iustin Pop -- An email address to which users can send suggestions, bug reports, -- and patches. -Maintainer: Iustin Pop +maintainer: Iustin Pop -- A copyright notice. -Copyright: (c) 2012, 2014 Google Inc. +copyright: (c) 2012, 2014, 2015 Google Inc. -Category: Data +category: Data -- Stability field. -Stability: alpha +stability: stable -Bug-reports: https://github.com/iustin/prefix-units/issues +bug-reports: https://github.com/iustin/prefix-units/issues -Build-type: Simple +build-type: Simple -- Extra files to be distributed with the package, such as examples or -- a README. -Extra-source-files: README.md CHANGES.md Makefile - --- Constraint on the version of Cabal needed to build this package. -Cabal-version: >= 1.8.0.2 +extra-source-files: README.md CHANGES.md Makefile example.hs -Tested-with: GHC==6.12.1, GHC==7.4.1, GHC==7.6.3 +tested-with: GHC==8.0.2 + , GHC==8.2.2 + , GHC==8.4 + , GHC==8.6 + , GHC==8.8 + , GHC==8.10 + , GHC==9.0 + , GHC==9.2 + , GHC==9.4 + , GHC==9.6 -Source-repository head +source-repository head Type: git Location: https://github.com/iustin/prefix-units.git -Source-repository this +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 +library -- Modules exported by the library. - Exposed-modules: Data.Prefix.Units + exposed-modules: Data.Prefix.Units -- Packages needed in order to build this package. - Build-depends: base >= 3 && < 5 + build-depends: base >= 3 && < 5 -- Modules not exported by this package. - Other-modules: + other-modules: Data.Prefix.Units.Compat - GHC-Options: -Wall + ghc-options: -Wall - Extensions: Safe TypeSynonymInstances FlexibleInstances + default-language: Haskell2010 + default-extensions: + Safe + TypeSynonymInstances + FlexibleInstances + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: @@ -96,6 +109,11 @@ , test-framework-hunit >= 0.2.7 , QuickCheck >= 2.4.2 , HUnit >= 1.2.4 + , deepseq >= 1.4.0.0 , prefix-units ghc-options: -Wall -fno-warn-orphans - Extensions: CPP + default-extensions: + CPP + ScopedTypeVariables + + default-language: Haskell2010 diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -39,6 +39,8 @@ module Main (main) where +import Control.Applicative (pure, (<$>)) +import Control.DeepSeq (force) import Data.Char (toUpper) import Data.List import Data.Maybe (isNothing) @@ -92,17 +94,44 @@ 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] +instance Arbitrary ParseOptions where + arbitrary = oneof [ pure UnitRequired + , UnitDefault <$> arbitrary + , pure UnitOptional + ] + allUnits :: [Unit] allUnits = [minBound..maxBound] @@ -127,13 +156,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 +174,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 @@ -188,7 +228,7 @@ -- | Fail to parse invalid symbols in any mode. testSymbolParsingFail :: ParseMode -> Property testSymbolParsingFail mode = - expectParseFailure (("NO-SUCH" `isInfixOf`) . map toUpper) $ + expectParseFailure (("NO-SUCH" `isInfixOf`) . force . map toUpper) $ parseSymbol mode "no-such" -- | Parsed values should be correct. @@ -198,26 +238,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 @@ -225,13 +277,13 @@ testFailParsing :: ParseMode -> Int -> Property testFailParsing pmode v = - expectParseFailure ("no-such" `isInfixOf`) + expectParseFailure (("no-such" `isInfixOf`) . force) (parseValue pmode ("no-such" ++ show v)::Either String Int) -- | Test fail parse on required unit. testParsingRequired :: ParseMode -> Int -> Property testParsingRequired pmode v = - expectParseFailure ("is required" `isInfixOf`) + expectParseFailure (("is required" `isInfixOf`) . force) (parseGeneric UnitRequired [] pmode (show v)::Either String Int) testParsingDefault :: Unit -> ParseMode -> Rational -> Property @@ -242,7 +294,7 @@ testParsingInvalidList :: Unit -> [Unit] -> Int -> Property testParsingInvalidList unit valid v = unit `notElem` valid && not (null valid) ==> - expectParseFailure ("not part of the accepted unit list" `isInfixOf`) + expectParseFailure (("not part of the accepted unit list" `isInfixOf`) . force) (parseGeneric UnitOptional valid ParseExact (show v ++ unitSymbol unit)::Either String Int) @@ -253,27 +305,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 +359,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 +398,37 @@ 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' + +-- | Trivial assertion that the Show instance works +testFormatModeShow :: FormatMode -> Property +testFormatModeShow = total . show + +-- | Trivial assertion that the Show instance works +testParseModeShow :: ParseMode -> Property +testParseModeShow = total . show + +-- | Trivial assertion that the Show instance works +testParseOptionsShow :: ParseOptions -> Property +testParseOptionsShow = total . show + -- * Test harness main :: IO () @@ -338,7 +441,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 +455,34 @@ , 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 + , testProperty "format mode show" testFormatModeShow + , testProperty "parse mode show" testParseModeShow + , testProperty "parse options show" testParseOptionsShow ] ]