diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,3 @@ +Version 0.1.0 + +* Initial release diff --git a/Data/Prefix/Units.hs b/Data/Prefix/Units.hs new file mode 100644 --- /dev/null +++ b/Data/Prefix/Units.hs @@ -0,0 +1,549 @@ +{- + +Copyright 2012, 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 and functions for parsing and formatting prefix units. + +This module defines the type 'Unit' and associated functions for +parsing numbers containing a prefix unit (e.g. @100M@) into +corespondingly scaled values (for the above example, @100000000@), and +for formatting numbers. + +The units definition is taken from the man page @units(7)@ and the web +sites and +. + +Since a give prefix unit (e.g. @m@) can be interpreted in different +ways, the module offers various ways to interpret this: + +* in a binary context (e.g. when talking about memory), this will be + interpreted as 2^20 (see 'ParseBinary') + +* in a SI context dealing with multiples, this will be intepreted as + 10^3 (see 'ParseKMGT') + +* in an exact parsing mode, this will be interpreded as the \"milli\" + prefix, i.e. 10^-3 (see 'ParseExact') + +The different parsing mode are offered as different contexts will have +different \"natural\" units, and always forcing precise parsing (which +also implies case-sensitivity) will lead to confusing user interfaces. + +The internal calculations when converting values are done via the +'Rational' type (with arbitrary precision), and precision loss happens +only at the last step of converting to the target type; for +float\/doubles this is 'fromRational', for integral types this is +'round'. + +A few examples are given below: + +>>> showValue (Left FormatBinary) 2048 +"2.0Ki" +>>> showValue (Left FormatSiAll) 0.0001 +"100.0u" +>>> showValue (Right Mebi) 1048576 +"1Mi" +>>> parseValue ParseExact "2.5Ki"::Either String Double +Right 2560.0 +>>> parseValue ParseBinary "2M"::Either String Int +Right 2097152 +>>> parseValue ParseExact "2ki" +Left "Unrecognised unit 'ki'" + +The failure in the last example is due to the fact that 'ParseExact' +is case-sensitive. + +-} + +module Data.Prefix.Units + ( + -- * Basic definitions + -- ** Types + Unit(..) + , RationalConvertible(..) + , siUnits + , siSupraunitary + , siKMGT + , binaryUnits + -- ** Unit-related functions + , unitMultiplier + , unitName + , unitSymbol + , fancySymbol + -- * Formatting functions + , FormatMode(..) + , recommendedUnit + , formatValue + , showValue + -- * Parsing functions + , ParseMode(..) + , parseSymbol + , parseValue + -- * Low-level generic functions + , unitRange + -- ** Parsing + , ParseOptions(..) + , parseExactSymbol + , parseBinarySymbol + , parseKMGTSymbol + , parseGeneric + -- ** Formatting + , showValueWith + ) where + +import Control.Monad.Instances () +import Data.Char (toUpper) +import Data.List (intercalate) + +--import Data.Prefix.Units.Helpers + +default () + +-- | The unit type. +data Unit = Yocto + | Zepto + | Atto + | Femto + | Pico + | Nano + | Micro + | Milli + | Centi + | Deci + | Deka + | Hecto + | Kilo + | Kibi + | Mega + | Mebi + | Giga + | Gibi + | Tera + | Tebi + | Peta + | Pebi + | Exa + | Exbi + | Zetta + | Yotta + 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] + +-- | List of binary units. +binaryUnits :: [Unit] +binaryUnits = [Kibi, Mebi, Gibi, Tebi, Pebi, Exbi] + +-- | List of units which are supraunitary (their multiplier is greater +-- than one). +siSupraunitary :: [Unit] +siSupraunitary = filter (>= Deka) siUnits + +-- | List of SI units which are greater or equal to 'Kilo'. +siKMGT :: [Unit] +siKMGT = filter (>= Kilo) siUnits + +-- | Returns the unit scaling \"multiplier\" (which can be either +-- supra- or sub-unitary): +-- +-- >>> unitMultiplier Micro +-- 1 % 1000000 +-- >>> 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) + +-- | 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" + +-- | 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" + +-- | Returns the unit symbol, which for the 'Micro' unit is not ASCII. +fancySymbol :: Unit -> String +fancySymbol Micro = "\xb5" +fancySymbol u = unitSymbol u + +-- * RationalConvertible + +-- | Typeclass for handling values that can be converted to\/from +-- 'Rational'. +class (Real a) => RationalConvertible a where + -- | Converts the value from Ratioal + convFromRational :: Rational -> a + +instance RationalConvertible Int where + convFromRational = round + +instance RationalConvertible Integer where + convFromRational = round + +instance RationalConvertible Float where + convFromRational = fromRational + +instance RationalConvertible Double where + convFromRational = fromRational + +instance RationalConvertible Rational where + convFromRational = id + +-- | Scales a given value to be represented in the desired unit's scale. +scaleToUnit :: (RationalConvertible a) => a -> Unit -> a +scaleToUnit val = convFromRational . (rational_val /) . unitMultiplier + where rational_val = toRational val + +-- | Scales a given value to units from a given unit's scale. +scaleFromUnit :: (RationalConvertible a) => a -> Unit -> a +scaleFromUnit val = convFromRational . (rational_val *) . unitMultiplier + where rational_val = toRational val + +-- * Formatting functionality + +-- | Defines the formatting modes. +data FormatMode + = FormatSiAll -- ^ Formats the value using any SI unit. + | 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@) + | 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 + +-- | The available units range for various format modes. +unitRange :: FormatMode -> [Unit] +unitRange FormatSiAll = siUnits +unitRange FormatSiSupraunitary = siSupraunitary +unitRange FormatSiKMGT = siKMGT +unitRange FormatBinary = binaryUnits + +-- | 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. +recommendedUnit :: (Real a) => FormatMode -> a -> Maybe Unit +recommendedUnit fmt val = + 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 + +-- | Computes the scaled value and unit for a given value +formatValue :: (RationalConvertible a) => + FormatOption -- ^ The desired 'FormatMode' or 'Unit' + -> a -- ^ The value to format + -> (a, Maybe Unit) -- ^ Scaled value and optional unit +formatValue fmt val = + let unit = either (flip recommendedUnit val) Just fmt + scaled = maybe val (scaleToUnit val) unit + in (scaled, unit) + +-- | Simple helper to generate the full string representation of an +-- integral value. +showValueWith :: (RationalConvertible a, Show a) => + (Unit -> String) -- ^ Function to convert the + -- (optional) unit into a + -- string, e.g. 'unitSymbol' or + -- 'fancySymbol' + -> FormatOption -- ^ The desired format mode + -> a -- ^ The value to show + -> String -- ^ Resulting string +showValueWith symbfn fmt val = + let (scaled, unit) = formatValue fmt val + in show scaled ++ maybe "" symbfn unit + +-- | 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 + -> a -- ^ The value to show + -> String -- ^ Resulting string +showValue = showValueWith unitSymbol + +-- * Parsing functionality + +-- | Error message for unknown unit. +unknownUnit :: String -> Either String Unit +unknownUnit unit = Left $ "Unrecognised unit '" ++ unit ++ "'" + +-- | Parses a symbol in the exact mode. See 'ParseExact' for details. +parseExactSymbol :: String -> Either String Unit +parseExactSymbol "y" = Right Yocto +parseExactSymbol "z" = Right Zepto +parseExactSymbol "a" = Right Atto +parseExactSymbol "f" = Right Femto +parseExactSymbol "p" = Right Pico +parseExactSymbol "n" = Right Nano +parseExactSymbol "u" = Right Micro +parseExactSymbol "m" = Right Milli +parseExactSymbol "c" = Right Centi +parseExactSymbol "d" = Right Deci +parseExactSymbol "da" = Right Deka +parseExactSymbol "h" = Right Hecto +parseExactSymbol "k" = Right Kilo +parseExactSymbol "Ki" = Right Kibi +parseExactSymbol "M" = Right Mega +parseExactSymbol "Mi" = Right Mebi +parseExactSymbol "G" = Right Giga +parseExactSymbol "Gi" = Right Gibi +parseExactSymbol "T" = Right Tera +parseExactSymbol "Ti" = Right Tebi +parseExactSymbol "P" = Right Peta +parseExactSymbol "Pi" = Right Pebi +parseExactSymbol "E" = Right Exa +parseExactSymbol "Ei" = Right Exbi +parseExactSymbol "Z" = Right Zetta +parseExactSymbol "Y" = Right Yotta +parseExactSymbol unit = unknownUnit unit + +-- | Helper for 'parseBinarySymbol' which only deals with upper-case +-- strings. +helperParseBinary :: String -> Either String Unit +helperParseBinary "K" = Right Kibi +helperParseBinary "KI" = Right Kibi +helperParseBinary "M" = Right Mebi +helperParseBinary "MI" = Right Mebi +helperParseBinary "G" = Right Gibi +helperParseBinary "GI" = Right Gibi +helperParseBinary "T" = Right Tebi +helperParseBinary "TI" = Right Tebi +helperParseBinary "P" = Right Pebi +helperParseBinary "PI" = Right Pebi +helperParseBinary "E" = Right Exbi +helperParseBinary "EI" = Right Exbi +-- FIXME: error message will contain upper-case version of the symbol +helperParseBinary symbol = unknownUnit symbol + +-- | Parses a binary symbol. See 'ParseBinary' for details. +parseBinarySymbol :: String -> Either String Unit +parseBinarySymbol = helperParseBinary . upperSym + +-- | Helper for 'parseKMGTSymbol' which only deals with upper-case strings. +helperParseKMGT :: String -> Either String Unit +helperParseKMGT "K" = Right Kilo +helperParseKMGT "KI" = Right Kibi +helperParseKMGT "M" = Right Mega +helperParseKMGT "MI" = Right Mebi +helperParseKMGT "G" = Right Giga +helperParseKMGT "GI" = Right Gibi +helperParseKMGT "T" = Right Tera +helperParseKMGT "TI" = Right Tebi +helperParseKMGT "P" = Right Peta +helperParseKMGT "PI" = Right Pebi +helperParseKMGT "E" = Right Exa +helperParseKMGT "EI" = Right Exbi +helperParseKMGT "Z" = Right Zetta +helperParseKMGT "Y" = Right Yotta +-- FIXME: error message will contain upper-case version of the symbol +helperParseKMGT symbol = unknownUnit symbol + +-- | Parses the given symbol as one of the \"big\" units (kilo/kibi +-- and above). This allows the parsing to be case-insensitive. +parseKMGTSymbol :: String -> Either String Unit +parseKMGTSymbol = helperParseKMGT . upperSym + +-- | Defines available parse modes. +data ParseMode + = ParseExact -- ^ Exact parser mode. This mode is fully + -- case-sensitive. + | ParseKMGT -- ^ Parses only units with bigger than 'Kilo', + -- respectively 'Kibi' (for binary units). This allows + -- the parser to be case-insensitive. + | ParseBinary -- ^ Parses binary units only. In this mode, both the + -- exact and shortened forms are accepted (e.g. both + -- \"k\" and \"ki\" will be converted into + -- 'Kibi'). Furthermore, the parsing is + -- case-insensitive. + deriving (Show, Enum, Bounded) + +-- | Defines unit handling mode on parse. +data ParseOptions + = UnitRequired -- ^ Requires that the input string + -- has a unit. + | UnitDefault Unit -- ^ If unit is missing, use a + -- default one. + | UnitOptional -- ^ The unit is optional, a missing + -- one means the value is not + -- scaled. + deriving (Show) + +-- | Parses a unit from a string. The exact parsing mode determines +-- the rules for parsing and the range of possible units. +parseSymbol :: ParseMode -> String -> Either String Unit +parseSymbol ParseExact = parseExactSymbol +parseSymbol ParseKMGT = parseKMGTSymbol +parseSymbol ParseBinary = parseBinarySymbol + +-- | Generic parse routine. Takes two function arguments which fix the +-- initial and final conversion, a parse mode and the string to be +-- parsed. +parseValue :: (Read a, RationalConvertible a) => + ParseMode -- ^ The desired parse mode + -> String -- ^ String to be parsed + -> Either String a +parseValue = parseGeneric UnitOptional [] + +-- | Validate a parsed unit using a given valid options list. +validUnit :: [Unit] -> Unit -> Either String Unit +validUnit [] unit = Right unit +validUnit ulist unit = + if unit `notElem` ulist + then Left $ "Unit '" ++ show unit ++ "' not part of the accepted" ++ + " unit list (" ++ intercalate ", " (map show ulist) ++ ")" + else Right unit + +-- | Parses a string unit depending on the various options and modes. +processUnit :: ParseOptions + -> 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) + +-- | Generic parse routine. Takes two function arguments which fix the +-- initial and final conversion, a parse mode and the string to be +-- parsed. +parseGeneric :: (Read a, RationalConvertible a) => + ParseOptions -- ^ Unit options + -> [Unit] -- ^ Optional list of valid units + -> ParseMode -- ^ The desired parse mode + -> String -- ^ String to be parsed + -> Either String a +parseGeneric popts valid_units pmode str = + case reads str of + [(v, suffix)] -> + let unit_suffix = dropWhile (== ' ') suffix + unit = processUnit popts pmode valid_units unit_suffix + in maybe (Right v) (fmap (scaleFromUnit v)) unit + _ -> Left $ "Can't parse string '" ++ str ++ "'" + +-- | Converts a string to upper-case. +upperSym :: String -> String +upperSym = map toUpper diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright 2012, 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. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,26 @@ +CABAL_OPTS = --hyperlink-source + +build: + cabal build + +int-docs: + cabal haddock \ + $(CABAL_OPTS) \ + --internal + +haddock: + cabal haddock \ + $(CABAL_OPTS) + +configure: + cabal clean + cabal configure --enable-tests --enable-library-coverage + +test: + cabal build + cabal test + +dist: + cabal sdist + +.PHONY: build int-docs haddock configure test dist diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,42 @@ +prefix-units package +==================== + +This package defines a datatype (`Unit`) and associated +parsing/formatting functions so that command line applications can +handle "nice" values like: + + $ cmd create-file foo 100G + Done. + $ cmd ls-file foo + Size is 100Gi + $ cmd ls-files + foo 100Gi + bar 14Ki + +And so on. For details on the API, look at the Haddock documentation +for the `Data.Prefix.Units` module. + +For building and installing, `cabal configure` and related commands +are enough. Run `cabal configure --enable-tests && cabal build && +cabal test` if you want to run the unit-tests. + +TODO +---- + +The current interface of the library works, but is not nicely +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 +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. + +The RationalConvertible type class has only a few instances; ideally +we'd have `instance Integral a => RationalConvertible a` and similar +for `Fractional`, but this doesn't work as such in Haskell, so we're +stuck with the manual derivation. + +The current behaviour is case-sensitive for all units in `ParseExact` +mode, which means that one has to use (in this mode) `Ki` for the +binary unit `Kibi`. This seems suboptimal, since the binary units are +unique irrespective of casing. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/prefix-units.cabal b/prefix-units.cabal new file mode 100644 --- /dev/null +++ b/prefix-units.cabal @@ -0,0 +1,98 @@ +-- 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 + +-- 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 + +-- A short (one-line) description of the package. +Synopsis: A basic library for SI/binary prefix units + +-- A longer description of the package. +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. + + For more details, see the man page units(7), + and + . + +-- URL for the project homepage or repository. +Homepage: http://code.google.com/p/prefix-units/ + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Iustin Pop + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: Iustin Pop + +-- A copyright notice. +Copyright: (c) 2012 Google Inc. + +Category: Data + +-- Stability field. +Stability: alpha + +Bug-reports: https://code.google.com/p/prefix-units/issues/ + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +Extra-source-files: README.md CHANGES Makefile + +-- 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 + +Source-repository head + Type: git + Location: https://code.google.com/p/prefix-units/ + +Source-repository this + Type: git + Location: https://code.google.com/p/prefix-units/ + Tag: prefix-units-v0.1.0 + +Library + -- Modules exported by the library. + Exposed-modules: Data.Prefix.Units + + -- Packages needed in order to build this package. + Build-depends: base >= 3 && < 5 + + -- Modules not exported by this package. + Other-modules: + + GHC-Options: -Wall + + Extensions: Safe TypeSynonymInstances FlexibleInstances + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + +Test-Suite test-units + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Properties.hs + build-depends: base >= 3 && < 5 + , Cabal >= 1.9.2 + , test-framework >= 0.6 && < 0.7 + , test-framework-quickcheck2 >= 0.2.12 && < 0.3 + , QuickCheck >= 2.4.2 && < 2.5 + , prefix-units + ghc-options: -Wall -fno-warn-orphans diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,350 @@ +{- + +Copyright 2012, 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. + +-} + +{- | Tests for the Data.Prefix.Units module + +-} + +module Main (main) where + +import Data.Char (toUpper) +import Data.List +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + +import Data.Prefix.Units + +-- * Test helpers + +failTest :: String -> Property +failTest msg = printTestCase msg False + +-- | Checks for equality with proper annotation. +(==?) :: (Show a, Eq a) => a -> a -> Property +(==?) x y = printTestCase + ("Expected equality, but '" ++ + show x ++ "' /= '" ++ show y ++ "'") (x == y) +infix 3 ==? + +-- | Formats a failed-to-parse-unit message. +failParseUnit :: Unit -> String -> Property +failParseUnit unit err = + failTest $ "Failed to parse unit '" ++ unitName unit ++ "': " ++ err + +-- | Fails unless we received an error message that passes a given +-- condition. +expectParseFailure :: (Show a) => + (String -> Bool) + -> Either String a + -> Property +expectParseFailure fn (Left err) = + printTestCase "Unexpected error message" $ fn err +expectParseFailure _ (Right v) = + failTest $ "Unexpected parse with result " ++ show v + +-- | Expect a parse result to be a given value. +expectParse :: (Real a, Real b) => a -> Unit -> Either String b -> Property +expectParse _ unit (Left err) = failParseUnit unit err +expectParse v unit (Right v') = + printTestCase "Parsed wrong value: " $ + toRational v' ==? toRational v * unitMultiplier unit + +-- * Instances + +instance Arbitrary Unit where + arbitrary = elements [minBound..maxBound] + +instance Arbitrary FormatMode where + arbitrary = elements [minBound..maxBound] + +instance Arbitrary ParseMode where + arbitrary = elements [minBound..maxBound] + +allUnits :: [Unit] +allUnits = [minBound..maxBound] + +-- * Actual tests + +-- ** Definitions + +testUniqueNames :: Property +testUniqueNames = + let names = map unitName allUnits + in names ==? nub names + +testUniqueSymbols :: Property +testUniqueSymbols = + let symbols = map unitSymbol allUnits + in symbols ==? nub symbols + +testUniqueFancySymbols :: Property +testUniqueFancySymbols = + let symbols = map fancySymbol allUnits + in symbols ==? nub symbols + +testOrdering :: Property +testOrdering = + let si_mult = map unitMultiplier $ sort siUnits + bin_mult = map unitMultiplier $ sort binaryUnits + all_mult = map unitMultiplier allUnits -- no sorting here! + in si_mult ==? sort si_mult .&&. + bin_mult ==? sort bin_mult .&&. + all_mult ==? sort all_mult + +testSIBinary :: Property +testSIBinary = + printTestCase "SI unit lists contain binary prefixes" $ + (null (siUnits `intersect` binaryUnits)) .&&. + (null (siKMGT `intersect` binaryUnits)) .&&. + (null (siSupraunitary `intersect` binaryUnits)) + +-- ** Parsing + +testNullUnitInt :: Int -> ParseMode -> Property +testNullUnitInt v pmode = + case parseValue pmode (show v) of + Left err -> failTest $ "Failed to parse empty unit: " ++ err + Right v' -> printTestCase "Parsed wrong value:" (v ==? v') + +testNullUnitFrac :: Double -> ParseMode -> Property +testNullUnitFrac d pmode = + case parseValue pmode (show d) of + Left err -> failTest $ "Failed to parse empty unit: " ++ err + Right d' -> printTestCase "Parsed wrong value:" (d ==? d') + +testSymbolParsingExact :: Unit -> Property +testSymbolParsingExact unit = + case parseExactSymbol (unitSymbol unit) of + Left err -> failParseUnit unit err + Right unit' -> printTestCase "Parsed wrong unit: " (unit ==? unit') + +-- | Binary units should parse themselves in explicit binary mode. +testSymbolParsingBinary :: Property +testSymbolParsingBinary = + forAll (elements binaryUnits) $ \unit -> + case parseBinarySymbol (unitSymbol unit) of + Left err -> failParseUnit unit err + Right unit' -> printTestCase "Parsed wrong unit: " (unit ==? unit') + +-- | Binary units should parse themselves in all parsing modes. +testSymbolParsingBinaryAbbrev :: Property +testSymbolParsingBinaryAbbrev = + forAll (elements binaryUnits) $ \unit -> + case parseSymbol ParseBinary (take 1 (unitSymbol unit)) of + Left err -> failParseUnit unit err + Right unit' -> printTestCase "Parsed wrong unit: " (unit ==? unit') + +-- | Binary units should parse themselves in all parsing modes. +testSymbolParsingBinaryAll :: ParseMode -> Property +testSymbolParsingBinaryAll mode = + forAll (elements binaryUnits) $ \unit -> + case parseSymbol mode (unitSymbol unit) of + Left err -> failParseUnit unit err + Right unit' -> printTestCase "Parsed wrong unit: " (unit ==? unit') + +-- | Fail to parse invalid symbols in any mode. +testSymbolParsingFail :: ParseMode -> Property +testSymbolParsingFail mode = + expectParseFailure (("NO-SUCH" `isInfixOf`) . map toUpper) $ + parseSymbol mode ("no-such") + +-- | Parsed values should be correct. +testParsingIntKMGT :: Int -> Property +testParsingIntKMGT v = + forAll (elements (siKMGT ++ binaryUnits)) $ \unit -> + let str = show v ++ unitSymbol unit in + expectParse v unit (parseValue ParseKMGT str::Either String Integer) + +-- | Parsed 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 = + let str = show d ++ unitSymbol unit in + case (parseValue ParseExact str)::Either String Double of + Left err -> failParseUnit unit err + Right d' -> printTestCase ("Parsing of " ++ str ++ " failed: ") $ + d' ==? fromRational (toRational d * unitMultiplier unit) + +-- | Parsed values should be correct. +testParsingRational :: Unit -> Integer -> Property +testParsingRational unit v = + let str = show v ++ "%1" ++ unitSymbol unit in + expectParse v unit (parseValue ParseExact str::Either String Rational) + +testFailParsing :: ParseMode -> Int -> Property +testFailParsing pmode v = + expectParseFailure ("no-such" `isInfixOf`) + (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`) + (parseGeneric UnitRequired [] pmode (show v)::Either String Int) + +testParsingDefault :: Unit -> ParseMode -> Rational -> Property +testParsingDefault unit pmode v = + expectParse v unit + (parseGeneric (UnitDefault unit) [] pmode (show v)::Either String Rational) + +testParsingInvalidList :: Unit -> [Unit] -> Int -> Property +testParsingInvalidList unit valid v = + unit `notElem` valid && not (null valid) ==> + expectParseFailure ("not part of the accepted unit list" `isInfixOf`) + (parseGeneric UnitOptional valid ParseExact + (show v ++ unitSymbol unit)::Either String Int) + +testParsingValidList :: Unit -> [Unit] -> Rational -> Property +testParsingValidList unit valid v = + unit `elem` valid && not (null valid) ==> + expectParse v unit + (parseGeneric UnitOptional valid ParseExact + (show v ++ unitSymbol unit)::Either String Rational) + +-- ** Formatting + +testTrivialFormattingRec :: FormatMode -> Property +testTrivialFormattingRec 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) + +testTrivialFormattingShow :: FormatMode -> Property +testTrivialFormattingShow fmt = + showValue (Left fmt) (0::Int) ==? "0" .&&. + showValue (Left fmt) (0::Double) ==? show (0::Double) + +testRecommend :: Property +testRecommend = + forAll (elements [FormatSiAll, FormatBinary]) $ \fmt -> + forAll (elements (unitRange fmt)) $ \unit -> + case recommendedUnit fmt (unitMultiplier unit) of + Nothing -> failTest $ "Expected recommendation of unit " ++ + unitName unit ++ " but got nothing" + Just unit' -> printTestCase "Mismatch in recommended unit: " $ + unit ==? unit' + +testForceUnit :: Unit -> Rational -> Property +testForceUnit unit v = + case formatValue (Right unit) v of + (v', Just u') -> printTestCase "Invalid value/unit computed" $ + unit ==? u' .&&. + v ==? v' * unitMultiplier unit + x -> failTest $ "Invalid result from formatValue: " ++ show x + +testFormatIntegral :: Property +testFormatIntegral = + forAll (elements [FormatSiSupraunitary, FormatBinary]) $ \fmt -> + forAll (elements (unitRange fmt)) $ \unit -> + let fmted = formatValue (Left fmt) . truncate . unitMultiplier $ unit + in fmted ==? (1::Integer, Just unit) + +testFormatFractional :: Property +testFormatFractional = + forAll (elements [FormatSiSupraunitary, FormatBinary]) $ \fmt -> + forAll (elements (unitRange fmt)) $ \unit -> + let fmted = formatValue (Left fmt) . unitMultiplier $ unit + in fmted ==? (1::Rational, Just unit) + +testShowIntegralBinary :: Property +testShowIntegralBinary = + forAll (elements binaryUnits) $ \ unit -> + let value = truncate (unitMultiplier unit)::Integer in + printTestCase ("Formatting/showing unit " ++ show unit) $ + showValue (Left FormatBinary) value ==? "1" ++ unitSymbol unit + +testShowRational :: Unit -> Property +testShowRational unit = + let fmtmode = if unit `elem` binaryUnits then FormatBinary else FormatSiAll + value = unitMultiplier unit + in printTestCase ("Formatting/showing unit " ++ show unit) $ + showValue (Left fmtmode) value ==? "1 % 1" ++ unitSymbol unit + +-- * Test harness + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = + [ testGroup "definitions" + [ testProperty "unique names" testUniqueNames + , testProperty "unique symbols" testUniqueSymbols + , testProperty "unique fancy symbols" testUniqueFancySymbols + , testProperty "ordering" testOrdering + , testProperty "type mixup" testSIBinary + ] + , testGroup "parsing" + [ testProperty "null unit integral" testNullUnitInt + , testProperty "null unit fractional" testNullUnitFrac + , testProperty "symbol parsing/exact" testSymbolParsingExact + , testProperty "symbol parsing/binary" testSymbolParsingBinary + , testProperty "symbol parsing/binary-all" testSymbolParsingBinaryAll + , testProperty "symbol parsing/binary-abbrev" testSymbolParsingBinaryAbbrev + , testProperty "symbol parsing/failure" testSymbolParsingFail + , testProperty "parsing/integral-kmgt" testParsingIntKMGT + , testProperty "parsing/integral" testParsingInt + , testProperty "parsing/fractional" 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 + ] + , testGroup "formatting" + [ testProperty "trivial formatting/recommend" testTrivialFormattingRec + , testProperty "trivial formatting/fmt" testTrivialFormattingFmt + , testProperty "trivial formatting/show" testTrivialFormattingShow + , testProperty "recommend" testRecommend + , testProperty "force unit" testForceUnit + , testProperty "format/int" testFormatIntegral + , testProperty "format/frac" testFormatFractional + , testProperty "show/integral binary" testShowIntegralBinary + , testProperty "show/rational" testShowRational + ] + ]