diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,6 @@ + +# jinquantities changelog +--- + +## 0.1.0 (2018-09-07) +- Fork from https://github.com/jdreaver/quantities diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2018-2019, Eliott Tixier, Novadiscovery +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder 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 +HOLDER 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/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/jinquantities.cabal b/jinquantities.cabal new file mode 100644 --- /dev/null +++ b/jinquantities.cabal @@ -0,0 +1,82 @@ +name: jinquantities +version: 0.1.0 +author: Eliott Tixier +maintainer: Eliott Tixier +build-type: Simple +cabal-version: >= 1.18 +copyright: Copyright (c) 2018-2019 Eliott Tixier, Novadiscovery +license: BSD3 +license-file: LICENSE +synopsis: Unit conversion and manipulation library. +description: Credit goes to https://github.com/jdreaver/quantities + from which this package is initially a fork. + A library for creating and manipulating physical + quantities, which are a numerical value + associated with a unit of measurement. Included + is an expression parser and a huge list of + predefined quantities with which to parse + strings into a Quantity datatype. Once created, + a quantity can be converted to different units + or queried for its dimensionality. A user can + also operate on quantities arithmetically, and + doing so uses automatic unit conversion and + simplification. + +category: Data, Math, Physics +homepage: http://github.com/eltix/quantities +extra-source-files: CHANGES.md + + +library + default-language: Haskell2010 + exposed-modules: Data.Quantities + , Data.Quantities.Convert + , Data.Quantities.Constructors + , Data.Quantities.Data + , Data.Quantities.DefaultUnits + , Data.Quantities.Definitions + , Data.Quantities.DefinitionParser + , Data.Quantities.ExprParser + hs-source-dirs: library + ghc-options: -Wall + build-depends: base >=4 && < 5, containers, mtl, parsec + +executable quantities + default-language: Haskell2010 + Hs-Source-Dirs: . + Main-Is: quantities.hs + build-depends: base >=4 && < 5, quantities, containers, mtl, parsec + Buildable: True + +test-suite hspec + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: test-suite library + main-is: Spec.hs + type: exitcode-stdio-1.0 + build-depends: base >=4 && < 5, quantities, hspec, containers, mtl, parsec + +test-suite hlint + build-depends: base, hlint + default-language: Haskell2010 + hs-source-dirs: test-suite + main-is: HLint.hs + type: exitcode-stdio-1.0 + +test-suite doctest + build-depends: base, doctest, Glob + default-language: Haskell2010 + hs-source-dirs: test-suite + main-is: DocTest.hs + type: exitcode-stdio-1.0 + +test-suite coverage + build-depends: base, process, regex-compat + default-language: Haskell2010 + hs-source-dirs: test-suite + main-is: DocCoverage.hs + type: exitcode-stdio-1.0 + +source-repository head + type: git + location: https://github.com/etixier/quantities.git diff --git a/library/Data/Quantities.hs b/library/Data/Quantities.hs new file mode 100644 --- /dev/null +++ b/library/Data/Quantities.hs @@ -0,0 +1,127 @@ +-- | This package is used to create and manipulate physical quantities, which +-- are a numerical value associated with a unit of measurement. +-- +-- In this package, values with units are represented with the Quantity type. +-- Included is an expression parser and a huge list of predefined quantities +-- with which to parse strings into a Quantity datatype. Once created, a +-- quantity can be converted to different units or queried for its +-- dimensionality. A user can also operate on quantities arithmetically, and +-- doing so uses automatic unit conversion and simplification. + + +module Data.Quantities + ( + -- * Constructors + -- $constructors + fromString + , unitsFromString + , Definitions + , Quantity + , magnitude + , units + , CompoundUnit + -- * Conversion + -- $conversion + , convert + , convertBase + , dimensionality + -- * Quantity arithmetic + -- $arithmetic + , addQuants + , subtractQuants + , multiplyQuants + , divideQuants + , exptQuants + -- * Custom definitions + -- $custom-defs + , fromString' + , readDefinitions + , defaultDefString + -- * Error type + , QuantityError(..) + , QuantityComputation + ) where + + +import Data.Quantities.Constructors (fromString, fromString', unitsFromString) +import Data.Quantities.Convert (convert, convertBase, addQuants, subtractQuants, + dimensionality) +import Data.Quantities.Data +import Data.Quantities.Definitions (readDefinitions) +import Data.Quantities.DefaultUnits (defaultDefString) + + +-- $setup +-- >>> import Control.Applicative + + +-- $constructors +-- +-- Currently, one constructor is supported to create quantities: 'fromString'. +-- There is an included expression parser that can parse values and strings +-- corresponding to builtin units. To view defined unit types, look at the +-- /source code/ for 'defaultDefString'. + +-- $conversion +-- +-- These functions are used to convert quantities from one unit type to +-- another. + + +-- $arithmetic +-- +-- Once created, quantities can be manipulated using the included arithmetic +-- functions. +-- +-- >>> let (Right x) = fromString "m/s" +-- >>> let (Right y) = fromString "mile/hr" +-- >>> x `multiplyQuants` y +-- 1.0 meter mile / hour / second +-- >>> x `divideQuants` y +-- 1.0 hour meter / mile / second +-- >>> x `addQuants` y +-- Right 1.4470399999999999 meter / second +-- >>> x `subtractQuants` y +-- Right 0.55296 meter / second +-- >>> x `exptQuants` 1.5 +-- 1.0 meter ** 1.5 / second ** 1.5 +-- +-- The functions 'multiplyQuants', 'divideQuants', and 'exptQuants' change +-- units, and the units of the result are reduced to simplest terms. +-- +-- >>> x `divideQuants` x +-- 1.0 +-- >>> fmap (multiplyQuants x) $ fromString "s" +-- Right 1.0 meter +-- >>> x `exptQuants` 0 +-- 1.0 + + +-- $custom-defs +-- +-- You don't have to use the default definitions provided by +-- 'defaultDefString'. Here is an example of adding a new unit called +-- @metric_foot@. +-- +-- >>> let myDefString = defaultDefString ++ "\n" ++ "metric_foot = 300mm" +-- >>> let (Right d') = readDefinitions myDefString +-- >>> let myFromString = fromString' d' +-- >>> myFromString "metric_foot" +-- Right 1.0 metric_foot +-- >>> convertBase <$> myFromString "metric_foot" +-- Right 0.3 meter +-- +-- It is usually much easier to copy the source code for 'defaultDefString' and +-- add your definitions in the appropriate spot (for example, put @metric_foot@ +-- next to the other unit definitions). Then, use 'fromString'' to create your +-- Quantity constructor. +-- +-- NOTE: It is very important not to perform conversions on two quantities from +-- different Definitions. Most of the error checking for undefined units is +-- done when a unit is created, and not when performing conversions. We try to +-- catch when different definitions are used. +-- +-- >>> let (Right m) = fromString "m" +-- >>> let (Right ft) = myFromString "ft" +-- >>> convert m (units ft) +-- Left (DifferentDefinitionsError meter foot) diff --git a/library/Data/Quantities/Constructors.hs b/library/Data/Quantities/Constructors.hs new file mode 100644 --- /dev/null +++ b/library/Data/Quantities/Constructors.hs @@ -0,0 +1,65 @@ +-- | Defines the common constructors used to build quantities. +module Data.Quantities.Constructors where + +import Data.Quantities.Data +import Data.Quantities.DefaultUnits (defaultDefString) +import Data.Quantities.Definitions (readDefinitions) +import Data.Quantities.ExprParser (parseExprQuant) + +-- | Default set of definitions that come predefined. +defaultDefinitions :: Either (QuantityError Double) Definitions +defaultDefinitions = readDefinitions defaultDefString + +-- $setup +-- >>> import Data.Quantities + +-- | Create a Quantity by parsing a string. Uses an 'UndefinedUnitError' for +-- undefined units. Handles arithmetic expressions as well. +-- +-- >>> fromString "25 m/s" +-- Right 25.0 meter / second +-- >>> fromString "fakeunit" +-- Left (UndefinedUnitError "fakeunit") +-- >>> fromString "ft + 12in" +-- Right 2.0 foot +-- +-- This function also supports unit conversions, by placing \"=>\" in between +-- two valid expressions. This behavior is undefined (and returns a +-- 'ScalingFactorError') if the quantity to be converted to has a magnitude. +-- +-- >>> fromString "min => s" +-- Right 60.0 second +-- >>> fromString "2 ft + 6 in => ft" +-- Right 2.5 foot +-- >>> fromString "m => 3 ft" +-- Left (ScalingFactorError 3.0 foot) +-- +-- Make sure not to use dimensional quantities in exponents. +-- +-- >>> fromString "m ** 2" +-- Right 1.0 meter ** 2 +-- >>> fromString "m ** (2s)" +-- Left (ParserError "Used non-dimensionless exponent in ( Right 1.0 meter ) ** ( Right 2.0 second )") +fromString :: String -> Either (QuantityError Double) (Quantity Double) +fromString s = case defaultDefinitions of + (Right d) -> parseExprQuant d s + (Left d) -> Left d + + +-- | Create quantities with custom definitions. +-- +-- >>> let myDefString = defaultDefString ++ "\nmy_unit = 100 s" +-- >>> let (Right d) = readDefinitions myDefString +-- >>> let myFromString = fromString' d +-- >>> myFromString "25 my_unit" +-- Right 25.0 my_unit +fromString' :: Definitions -> String -> Either (QuantityError Double) (Quantity Double) +fromString' = parseExprQuant + + +-- | Parse units from a string. Equivalent to @fmap units . fromString@ +-- +-- >>> unitsFromString "N * s" +-- Right newton second +unitsFromString :: String -> Either (QuantityError Double) CompoundUnit +unitsFromString = fmap units . fromString diff --git a/library/Data/Quantities/Convert.hs b/library/Data/Quantities/Convert.hs new file mode 100644 --- /dev/null +++ b/library/Data/Quantities/Convert.hs @@ -0,0 +1,104 @@ +-- | Module to perform unit conversions, compute dimensionality, and convert to +-- base units. +module Data.Quantities.Convert where + +import Data.List (sort) +import qualified Data.Map as M + +import Data.Quantities.Data + +-- $setup +-- >>> import Control.Applicative +-- >>> import Data.Quantities + +-- | Convert quantity to given units. +-- +-- >>> convert <$> fromString "m" <*> unitsFromString "ft" +-- Right (Right 3.280839895013123 foot) +convert :: (Fractional a) => Quantity a -> CompoundUnit -> + Either (QuantityError a) (Quantity a) +convert q us + | hq /= hus = Left $ DifferentDefinitionsError (units q) us + | otherwise = convert' (defs us) q us + where hq = defStringHash (defs' q) + hus = defStringHash (defs us) + + +-- | Convert a quantity to its base units. +-- +-- >>> convertBase <$> fromString "newton" +-- Right 1000.0 gram meter / second ** 2 +convertBase :: (Fractional a) => Quantity a -> Quantity a +convertBase x = convertBase' (defs' x) x + + +-- | Convert quantity to given units. +convert' :: (Fractional a) => Definitions -> Quantity a -> CompoundUnit -> + Either (QuantityError a) (Quantity a) +convert' d q us' + | dimq /= dimus = Left $ DimensionalityError (CompoundUnit d dimq) (CompoundUnit d dimus) + | otherwise = Right $ Quantity (mb / realToFrac mb') us' + where mb = magnitude $ convertBase' d q + mb' = magnitude $ toBase d (sUnits us') + dimq = dimensionality' d (units' q) + dimus = dimensionality' d (sUnits us') + + + +-- | Convert a quantity to its base units. +convertBase' :: (Fractional a) => Definitions -> Quantity a -> Quantity a +convertBase' d (Quantity m us) = Quantity (m * realToFrac mb) ub + where (Quantity mb ub) = toBase d (sUnits us) + + +-- | Converts a composite unit to its base quantity +toBase :: Definitions -> [SimpleUnit] -> Quantity Double +toBase d = foldr (multiplyQuants . simpleToBase d) unityQuant + where unityQuant = Quantity 1 (CompoundUnit d []) + + +-- | Converts a simple unit to its base quantity. +simpleToBase :: Definitions -> SimpleUnit -> Quantity Double +simpleToBase d (SimpleUnit sym pre pow) = Quantity m (CompoundUnit d us) + where (m', u') = bases d M.! sym + us = map (\(SimpleUnit s p pow') -> SimpleUnit s p (pow*pow')) u' + m = (m' * (prefixValues d M.! pre)) ** pow + + +-- | Computes dimensionality of quantity. +-- +-- >>> dimensionality <$> fromString "newton" +-- Right [length] [mass] / [time] ** 2 +dimensionality :: Quantity a -> CompoundUnit +dimensionality q = CompoundUnit (defs' q) dimUnits + where dimUnits = dimensionality' (defs' q) (units' q) + +-- | Computes dimensionality of a list of SimpleUnits. Stores the +-- dimensionality as a list of SimpleUnits as well, so we don't need a whole +-- new type. +dimensionality' :: Definitions -> [SimpleUnit] -> [SimpleUnit] +dimensionality' d us = sort $ map dim ub + where ub = units' $ toBase d us + dim (SimpleUnit sym _ pow) = SimpleUnit ('[' : unitTypes d M.! sym ++ "]") "" pow + + +-- | Adds two quantities. Second quantity is converted to units of +-- first quantity. +addQuants :: (Fractional a) => Quantity a -> Quantity a -> + Either (QuantityError a) (Quantity a) +addQuants = linearQuants (+) + + +-- | Subtract two quantities. Second quantity is converted to units of +-- first quantity. +subtractQuants :: (Fractional a) => Quantity a -> Quantity a -> + Either (QuantityError a) (Quantity a) +subtractQuants = linearQuants (-) + +-- | Helper function used in addQuants and subtractQuants. +linearQuants :: (Fractional a) => (a -> a -> a) -> Quantity a -> Quantity a + -> Either (QuantityError a) (Quantity a) +linearQuants f (Quantity m1 u1) q2 = case q of + (Right q') -> Right $ Quantity (f m1 (magnitude q')) u1 + (Left err) -> Left err + where q = convert q2 u1 diff --git a/library/Data/Quantities/Data.hs b/library/Data/Quantities/Data.hs new file mode 100644 --- /dev/null +++ b/library/Data/Quantities/Data.hs @@ -0,0 +1,250 @@ +-- | Base module for all data structures. +module Data.Quantities.Data where + +import Data.List (partition, sort) +import qualified Data.Map as M + +-- $setup +-- >>> import Control.Applicative +-- >>> import Data.Quantities + +-- | String representation of a unit. Examples: "meter", "foot" +type Symbol = String + +-- | Representation of single unit. For example: \"mm^2\" is +-- represented as +-- +-- > SimpleUnit { symbol = "meter", prefix = "milli", power = 2.0 } +data SimpleUnit = SimpleUnit { symbol :: String + , prefix :: String + , power :: Double } deriving (Eq, Ord) + +instance Show SimpleUnit where + show (SimpleUnit s pr p) + | p == 1 = sym + | otherwise = sym ++ " ** " ++ showPower p + where sym = pr ++ s + +-- | Data type to hold compound units, which are simple units multiplied +-- together. +data CompoundUnit = CompoundUnit { defs :: Definitions + -- ^ Definitions used to create the units. + , sUnits :: [SimpleUnit] + -- ^ List of SimpleUnits that is interpreted + -- as the units being multiplied together. + } deriving (Eq, Ord) + +instance Show CompoundUnit where + show (CompoundUnit _ us) = unwords . map showCompUnit' $ showSort us + +-- | Show a single unit, but prepend with '/' if negative +showCompUnit' :: SimpleUnit -> String +showCompUnit' su@(SimpleUnit _ _ p) + | p < 0 = "/ " ++ show (su { power = -p }) + | otherwise = show su + +{-# ANN showPower "HLint: ignore Too strict if" #-} +-- | Removes decimal if almost integer. +showPower :: Double -> String +showPower d = if isInt d then show (round d :: Integer) else show d + where isInt x = x == fromInteger (round x) + +-- | Will be used when we allow pretty printing of fractional units. +showPrettyNum :: (Show a, Num a) => a -> String +showPrettyNum x = map (pretty M.!) $ show x + where pretty = M.fromList $ zip "0123456789.-" "⁰¹²³⁴⁵⁶⁷⁸⁹·⁻" + + +-- | Combination of magnitude and units. +data Quantity a = Quantity + { magnitude :: a -- ^ Numerical magnitude of quantity. + -- + -- >>> magnitude <$> fromString "100 N * m" + -- Right 100.0 + , units :: CompoundUnit -- ^ Units associated with quantity. + -- + -- >>> units <$> fromString "3.4 m/s^2" + -- Right meter / second ** 2 + } deriving (Ord) + + +-- | Convenience function to extract SimpleUnit collection from Quantity's +-- CompoundUnit. +units' :: Quantity a -> [SimpleUnit] +units' = sUnits . units + +-- | Convenience function to extract Definitions from Quantity's CompoundUnit. +defs' :: Quantity a -> Definitions +defs' = defs . units + +instance (Show a) => Show (Quantity a) where + show (Quantity m us) = show m ++ " " ++ show us + + +-- | Convenience function to make quantity with no definitions. +baseQuant :: a -> [SimpleUnit] -> Quantity a +baseQuant m us = Quantity m (CompoundUnit emptyDefinitions us) + +-- | Sort units but put negative units at end. +showSort :: [SimpleUnit] -> [SimpleUnit] +showSort c = pos ++ neg + where (pos, neg) = partition (\q -> power q > 0) c + +instance (Eq a) => Eq (Quantity a) where + (Quantity m1 u1) == (Quantity m2 u2) = m1 == m2 && sort (sUnits u1) == sort (sUnits u2) + + +-- | Custom error type +data QuantityError a = UndefinedUnitError String + -- ^ Used when trying to parse an undefined unit. + | DimensionalityError CompoundUnit CompoundUnit + -- ^ Used when converting units that do not have the same + -- dimensionality (example: convert meter to second). + | UnitAlreadyDefinedError String + -- ^ Used internally when defining units and a unit is + -- already defined. + | PrefixAlreadyDefinedError String + -- ^ Used internally when defining units and a prefix is + -- already defined. + | ParserError String + -- ^ Used when a string cannot be parsed. + | DifferentDefinitionsError CompoundUnit CompoundUnit + -- ^ Used when two quantities come from different + -- Definitions. + | ScalingFactorError (Quantity a) + -- ^ Used when a scaling factor is present in a unit + -- conversion. + deriving (Show, Eq) + + +-- | Useful for monadic computations with 'QuantityError's. Some examples: +-- +-- > computation :: QuantityComputation Quantity +-- > computation = do +-- > x <- fromString "mile/hr" +-- > y <- unitsFromString "m/s" +-- > convert x y +-- +-- Returns @Right 0.44704 meter / second@ +-- +-- > computation :: QuantityComputation Quantity +-- > computation = do +-- > x <- fromString "BADUNIT" +-- > convertBase x +-- +-- Returns @Left (UndefinedUnitError "BADUNIT")@ +type QuantityComputation a = Either (QuantityError a) + +-- | Combines equivalent units and removes units with powers of zero. +reduceUnits :: Quantity a -> Quantity a +reduceUnits q = q { units = newUnits } + where newUnits = (units q) { sUnits = reduceUnits' (units' q) } + +-- | Helper function for reduceUnits. +reduceUnits' :: [SimpleUnit] -> [SimpleUnit] +reduceUnits' = removeZeros . reduceComp . sort + where reduceComp [] = [] + reduceComp (SimpleUnit x pr1 p1 : SimpleUnit y pr2 p2: xs) + | (x,pr1) == (y,pr2) = SimpleUnit x pr1 (p1+p2) : reduceComp xs + | otherwise = SimpleUnit x pr1 p1 : reduceComp (SimpleUnit y pr2 p2 : xs) + reduceComp (x:xs) = x : reduceComp xs + +-- | Removes units with powers of zero that are left over from other +-- computations. +removeZeros :: [SimpleUnit] -> [SimpleUnit] +removeZeros [] = [] +removeZeros (SimpleUnit _ _ 0.0 : xs) = removeZeros xs +removeZeros (x:xs) = x : removeZeros xs + +-- | Negate the powers of a list of SimpleUnits. +invertUnits :: [SimpleUnit] -> [SimpleUnit] +invertUnits = map invertSimpleUnit + +-- | Inverts unit by negating the power field. +invertSimpleUnit :: SimpleUnit -> SimpleUnit +invertSimpleUnit (SimpleUnit s pr p) = SimpleUnit s pr (-p) + +-- | Multiplies two quantities. +multiplyQuants :: (Num a) => Quantity a -> Quantity a -> Quantity a +multiplyQuants x y = reduceUnits $ Quantity mag newUnits + where mag = magnitude x * magnitude y + newUnits = (units x) { sUnits = units' x ++ units' y } + +-- | Divides two quantities. +divideQuants :: (Fractional a) => Quantity a -> Quantity a -> Quantity a +divideQuants x y = reduceUnits $ Quantity mag newUnits + where mag = magnitude x / magnitude y + newUnits = (units x) { sUnits = units' x ++ invertUnits (units' y) } + +-- | Exponentiates a quantity with an integer +exptQuants :: (Real a, Floating a) => Quantity a -> a -> Quantity a +exptQuants (Quantity x u) y = reduceUnits $ Quantity (x**y) newUnits + where expUnits = map (\(SimpleUnit s pr p) -> SimpleUnit s pr (p * realToFrac y)) + newUnits = u { sUnits = expUnits (sUnits u) } + +-- | Data type for the three definition types. Used to hold definitions +-- information when parsing. +data Definition = PrefixDefinition { defPrefix :: Symbol + , factor :: Double + , defSynonyms :: [Symbol]} + | BaseDefinition { base :: Symbol + , dimBase :: Symbol + , defSynonyms ::[Symbol]} + | UnitDefinition { defSymbol :: Symbol + , quantity :: Quantity Double + , defSynonyms :: [Symbol]} deriving (Show, Eq, Ord) + +-- | Holds information about defined units, prefixes, and bases. Used when +-- parsing new units and performing units conversions. +data Definitions = Definitions { bases :: M.Map String (Double, [SimpleUnit]) + -- ^ Map from symbol to base units and + -- conversion factor to those units. + , synonyms :: M.Map String String + -- ^ Map from alias to symbol. Symbols without + -- aliases are present as identity maps. + , unitsList :: [String] + -- ^ List of all units (no aliases). Used in + -- prefix parser, and to detect duplicate + -- definitions. + , prefixes :: [String] + -- ^ List of all prefixes (no aliases). Used + -- in prefix parser, and to detect duplicate + -- prefix definitions. + , prefixValues :: M.Map String Double + -- ^ Multiplicative factor of prefixes. + , prefixSynonyms :: M.Map String String + -- ^ Map from prefix alias to prefix. + , unitTypes :: M.Map String String + -- ^ Map from base symbols to unit types. + , defStringHash :: Int + -- ^ Hash of the definitions string used to + -- create definitions. Defaults to -1 if + -- modified or no string was used. + } deriving (Show, Ord) + +instance Eq Definitions where + d1 == d2 = defStringHash d1 == defStringHash d2 + +-- | Default, empty set of definitions. +emptyDefinitions :: Definitions +emptyDefinitions = Definitions { bases = M.empty + , synonyms = M.empty + , unitsList = [] + , prefixes = [] + , prefixValues = M.fromList [("", 1)] + , prefixSynonyms = M.fromList [("", "")] + , unitTypes = M.empty + , defStringHash = -1 } + + +-- | Combine two Definitions structures +unionDefinitions :: Definitions -> Definitions -> Definitions +unionDefinitions d1 d2 = Definitions { + bases = bases d1 `M.union` bases d2 + , synonyms = synonyms d1 `M.union` synonyms d2 + , unitsList = unitsList d1 ++ unitsList d2 + , prefixes = prefixes d1 ++ prefixes d2 + , prefixValues = prefixValues d1 `M.union` prefixValues d2 + , prefixSynonyms = prefixSynonyms d1 `M.union` prefixSynonyms d2 + , unitTypes = unitTypes d1 `M.union` unitTypes d2 + , defStringHash = -1 } diff --git a/library/Data/Quantities/DefaultUnits.hs b/library/Data/Quantities/DefaultUnits.hs new file mode 100644 --- /dev/null +++ b/library/Data/Quantities/DefaultUnits.hs @@ -0,0 +1,337 @@ +-- | Holds the default definition string. +module Data.Quantities.DefaultUnits (defaultDefString) where + +-- | View the source code for this declaration to see what units and prefixes +-- are defined by default. +-- +-- This string holds the definitions for units and prefixes. Base units are +-- defined by the name of the unit, the name of the base in brackets, and any +-- aliases for the unit after that, all separated by equal signs: @meter = +-- [length] = m@. Prefixes are defined by placing a dash after all identifiers, +-- and providing a value for the prefix: @milli- = 1e-3 = m-@. Other units are +-- defined by using /previously defined units/ in an expression: @minute = 60 * +-- second = min@. +-- +-- The reason these definitions aren't placed in a text file is so you don't +-- have to operate your whole program in the IO monad. Users can copy this file +-- into their source and modify definitions, or simply add a few definitions to +-- the end of this string. +-- +-- These definitions are taken almost verbatim from the Pint unit conversion +-- library for the Python programming language. Check them out on +-- . +defaultDefString :: String +defaultDefString = unlines [ + + -- decimal prefixes + "yocto- = 1e-24 = y-" + ,"zepto- = 1e-21 = z-" + ,"atto- = 1e-18 = a-" + ,"femto- = 1e-15 = f-" + ,"pico- = 1e-12 = p-" + ,"nano- = 1e-9 = n-" + ,"micro- = 1e-6 = u-" + ,"milli- = 1e-3 = m-" + ,"centi- = 1e-2 = c-" + ,"deci- = 1e-1 = d-" + ,"deca- = 1e+1 = da-" + ,"hecto- = 1e2 = h-" + ,"kilo- = 1e3 = k-" + ,"mega- = 1e6 = M-" + ,"giga- = 1e9 = G-" + ,"tera- = 1e12 = T-" + ,"peta- = 1e15 = P-" + ,"exa- = 1e18 = E-" + ,"zetta- = 1e21 = Z-" + ,"yotta- = 1e24 = Y-" + + -- binary_prefixes + ,"kibi- = 2**10 = Ki-" + ,"mebi- = 2**20 = Mi-" + ,"gibi- = 2**30 = Gi-" + ,"tebi- = 2**40 = Ti-" + ,"pebi- = 2**50 = Pi-" + ,"exbi- = 2**60 = Ei-" + ,"zebi- = 2**70 = Zi-" + ,"yobi- = 2**80 = Yi-" + + -- reference + ,"meter = [length] = m = metre" + ,"second = [time] = s = sec" + ,"ampere = [current] = A = amp" + ,"candela = [luminosity] = cd = candle" + ,"gram = [mass] = g" + ,"mole = [substance] = mol" + --,"degK = [temperature]; offset: 0 = K = kelvin" + ,"radian = [] = rad" + ,"bit = []" + ,"count = []" + + ,"pi = 3.14159265359" + ,"gstandard_gravity = 9.806650 * meter / second ** 2 = g_0 = g_n = gravity" + ,"speed_of_light = 299792458 * meter / second = c" + + -- acceleration + -- [acceleration] = [length] / [time] ** 2 + + -- Angle + ,"turn = 2 * pi * radian = revolution = cycle = circle" + ,"degree = pi / 180 * radian = deg = arcdeg = arcdegree = angular_degree" + ,"arcminute = arcdeg / 60 = arcmin = arc_minute = angular_minute" + ,"arcsecond = arcmin / 60 = arcsec = arc_second = angular_second" + ,"steradian = radian ** 2 = sr" + + -- Time + ,"minute = 60 * second = min" + ,"hour = 60 * minute = h = hr" + ,"day = 24 * hour" + ,"week = 7 * day" + ,"fortnight = 2 * week" + ,"year = 31556925.9747 * second" + ,"month = year/12" + ,"shake = 1e-8 * second" + ,"sidereal_day = day / 1.00273790935079524" + ,"sidereal_hour = sidereal_day/24" + ,"sidereal_minute = sidereal_hour/60" + ,"sidereal_second =sidereal_minute/60" + ,"sidereal_year = 366.25636042 * sidereal_day" + ,"sidereal_month = 27.321661 * sidereal_day" + ,"tropical_month = 27.321661 * day" + ,"synodic_month = 29.530589 * day = lunar_month" + ,"common_year = 365 * day" + ,"leap_year = 366 * day" + ,"julian_year = 365.25 * day" + ,"gregorian_year = 365.2425 * day" + ,"millenium = 1000 * year = millenia = milenia = milenium" + ,"eon = 1e9 * year" + ,"work_year = 2056 * hour" + ,"work_month = work_year/12" + + -- Length + ,"angstrom = 1e-10 * meter" + ,"inch = 2.54 * centimeter = international_inch = inches = international_inches = in" + ,"foot = 12 * inch = international_foot = ft = feet = international_foot = international_feet" + ,"mile = 5280 * foot = mi = international_mile" + ,"yard = 3 * feet = yd = international_yard" + ,"mil = inch / 1000 = thou" + ,"parsec = 3.08568025e16 * meter = pc" + ,"light_year = speed_of_light * julian_year = ly = lightyear" + ,"astronomical_unit = 149597870691 * meter = au" + ,"nautical_mile = 1.852e3 * meter = nmi" + ,"printers_point = 127 * millimeter / 360 = point" + ,"printers_pica = 12 * printers_point = pica" + ,"US_survey_foot = 1200 * meter / 3937" + ,"US_survey_yard = 3 * US_survey_foot" + ,"US_survey_mile = 5280 * US_survey_foot = US_statute_mile" + ,"rod = 16.5 * US_survey_foot = pole = perch" + ,"furlong = 660 * US_survey_foot" + ,"fathom = 6 * US_survey_foot" + ,"chain = 66 * US_survey_foot" + ,"barleycorn = inch / 3" + ,"arpentlin = 191.835 * feet" + ,"kayser = 1 / centimeter = wavenumber" + + + -- Mass + ,"ounce = 28.349523125 * gram = oz = avoirdupois_ounce" + ,"dram = oz / 16 = dr = avoirdupois_dram" + ,"pound = 0.45359237 * kilogram = lb = avoirdupois_pound" + ,"stone = 14 * lb = st" + ,"carat = 200 * milligram" + ,"grain = 64.79891 * milligram = gr" + ,"long_hundredweight = 112 * lb" + ,"short_hundredweight = 100 * lb" + ,"metric_ton = 1000 * kilogram = t = tonne" + ,"pennyweight = 24 * gram = dwt" + ,"slug = 14.59390 * kilogram" + ,"troy_ounce = 480 * gram = toz = apounce = apothecary_ounce" + ,"troy_pound = 12 * toz = tlb = appound = apothecary_pound" + ,"drachm = 60 * gram = apdram = apothecary_dram" + ,"atomic_mass_unit = 1.660538782e-27 * kilogram = u = amu = dalton = Da" + ,"scruple = 20 * gram" + ,"bag = 94 * lb" + ,"ton = 2000 * lb = short_ton" + + -- Force + --[force] = [mass] * [acceleration] + ,"newton = kilogram * meter / second ** 2 = N" + ,"dyne = gram * centimeter / second ** 2 = dyn" + ,"force_kilogram = g_0 * kilogram = kgf = kilogram_force = pond" + ,"force_gram = g_0 * gram = gf = gram_force" + ,"force_ounce = g_0 * ounce = ozf = ounce_force" + ,"force_pound = g_0 * lb = lbf = pound_force" + ,"force_ton = 2000 * force_pound = ton_force" + ,"poundal = lb * feet / second ** 2 = pdl" + ,"kip = 1000*lbf" + + -- Area + -- [area] = [length] ** 2 + ,"are = 100 * m**2" + ,"barn = 1e-28 * m ** 2 = b" + ,"cmil = 5.067075e-10 * m ** 2 = circular_mils" + ,"darcy = 9.869233e-13 * m ** 2" + ,"acre = 4046.8564224 * m ** 2 = international_acre" + ,"US_survey_acre = 160 * rod ** 2" + + -- Energy + ,"joule = newton * meter = J" + ,"erg = dyne * centimeter" + ,"btu = 1.05505585262e3 * joule = Btu = BTU = british_thermal_unit" + ,"eV = 1.60217653e-19 * J = electron_volt" + ,"thm = 100000 * BTU = therm = EC_therm" + ,"cal = 4.184 * joule = calorie = thermochemical_calorie" + ,"international_steam_table_calorie = 4.1868 * joule" + ,"ton_TNT = 4.184e9 * joule = tTNT" + ,"US_therm = 1.054804e8 * joule" + ,"E_h = 4.35974394e-18 * joule = hartree = hartree_energy" + + + -- Power + ,"watt = joule / second = W = volt_ampere = VA" + ,"horsepower = 33000 * ft * lbf / min = hp = UK_horsepower = British_horsepower" + ,"boiler_horsepower = 33475 * btu / hour" + ,"metric_horsepower = 75 * force_kilogram * meter / second" + ,"electric_horsepower = 746 * watt" + ,"hydraulic_horsepower = 550 * feet * lbf / second" + ,"refrigeration_ton = 12000 * btu / hour = ton_of_refrigeration" + + -- More Energy + ,"watt_hour = watt * hour = Wh = watthour" + + -- EM + ,"esu = 1 * erg**0.5 * centimeter**0.5 = statcoulombs = statC = franklin = Fr" + ,"esu_per_second = 1 * esu / second = statampere" + ,"ampere_turn = 1 * A" + ,"gilbert = 10 / (4 * pi ) * ampere_turn = G" + ,"coulomb = ampere * second = C" + ,"volt = joule / coulomb = V" + ,"farad = coulomb / volt = F" + ,"ohm = volt / ampere" + ,"siemens = ampere / volt = S = mho" + ,"weber = volt * second = Wb" + ,"tesla = weber / meter ** 2 = T" + ,"henry = weber / ampere = H" + ,"elementary_charge = 1.602176487e-19 * coulomb = e" + ,"chemical_faraday = 9.64957e4 * coulomb" + ,"physical_faraday = 9.65219e4 * coulomb" + ,"faraday = 96485.3399 * coulomb = C12_faraday" + ,"gamma = 1e-9 * tesla" + ,"gauss = 1e-4 * tesla" + ,"maxwell = 1e-8 * weber = mx" + ,"oersted = 1000 / (4 * pi) * A / m = Oe" + ,"statfarad = 1.112650e-12 * farad = statF = stF" + ,"stathenry = 8.987554e11 * henry = statH = stH" + ,"statmho = 1.112650e-12 * siemens = statS = stS" + ,"statohm = 8.987554e11 * ohm" + ,"statvolt = 2.997925e2 * volt = statV = stV" + ,"unit_pole = 1.256637e-7 * weber" + + + -- Frequency + ,"hertz = 1 / second = Hz = rps" + ,"revolutions_per_minute = revolution / minute = rpm" + ,"counts_per_second = count / second = cps" + + -- Information + ,"byte = 8 * bit = Bo = octet" + ,"baud = bit / second = Bd = bps" + + -- Textile + ,"denier = gram / (9000 * meter)" + ,"tex = gram/ (1000 * meter)" + ,"dtex = decitex" + + -- Pressure + -- [pressure] = [force] / [area] + ,"Hg = gravity * 13.59510 * gram / centimeter ** 3 = mercury = conventional_mercury" + ,"mercury_60F = gravity * 13.5568 * gram / centimeter ** 3" + ,"H2O = gravity * 1000 * kilogram / meter ** 3 = h2o = water = conventional_water" + ,"water_4C = gravity * 999.972 * kilogram / meter ** 3 = water_39F" + ,"water_60F = gravity * 999.001 * kilogram / m ** 3" + ,"pascal = newton / meter ** 2 = Pa" + ,"bar = 100000 * pascal" + ,"atmosphere = 101325 * pascal = atm = standard_atmosphere" + ,"technical_atmosphere = kilogram * gravity / centimeter ** 2 = at" + ,"torr = atm / 760" + ,"psi = pound * gravity / inch ** 2 = pound_force_per_square_inch" + ,"ksi = kip / inch ** 2 = kip_per_square_inch" + ,"barye = 0.1 * newton / meter ** 2 = barie = barad = barrie = baryd = Ba" + ,"mmHg = millimeter * Hg = mm_Hg = millimeter_Hg = millimeter_Hg_0C" + ,"cmHg = centimeter * Hg = cm_Hg = centimeter_Hg" + ,"inHg = inch * Hg = in_Hg = inch_Hg = inch_Hg_32F" + ,"inch_Hg_60F = inch * mercury_60F" + ,"inch_H2O_39F = inch * water_39F" + ,"inch_H2O_60F = inch * water_60F" + ,"footH2O = ft * water" + ,"cmH2O = centimeter * water" + ,"foot_H2O = ft * water = ftH2O" + ,"standard_liter_per_minute = 1.68875 * Pa * m ** 3 / s = slpm = slm" + + + -- Radiation + ,"Bq = Hz = becquerel" + ,"curie = 3.7e10 * Bq = Ci" + ,"rutherford = 1e6*Bq = rd = Rd" + ,"Gy = joule / kilogram = gray = Sv = sievert" + ,"rem = 1e-2 * sievert" + ,"rads = 1e-2 * gray" + ,"roentgen = 2.58e-4 * coulomb / kilogram = R" + + -- Velocity + -- [speed] = [length] / [time] + ,"knot = nautical_mile / hour = kt = knot_international = international_knot = nautical_miles_per_hour" + ,"mph = mile / hour = MPH" + ,"kph = kilometer / hour = KPH" + + -- Viscosity + -- [viscosity] = [pressure] * [time] + ,"poise = 1e-1 * Pa * second = P" + ,"stokes = 1e-4 * meter ** 2 / second = St" + ,"rhe = 10 / (Pa * s)" + + -- Volume + -- [volume] = [length] ** 3 + ,"liter = 1e-3 * m ** 3 = l = L = litre" + ,"cc = centimeter ** 3 = cubic_centimeter" + ,"stere = meter ** 3" + ,"gross_register_ton = 100 * foot ** 3 = register_ton = GRT" + ,"acre_foot = acre * foot = acre_feet" + ,"board_foot = foot ** 2 * inch = FBM" + ,"bushel = 2150.42 * inch ** 3 = bu = US_bushel" + ,"dry_gallon = bushel / 8 = US_dry_gallon" + ,"dry_quart = dry_gallon / 4 = US_dry_quart" + ,"dry_pint = dry_quart / 2 = US_dry_pint" + ,"gallon = 231 * inch ** 3 = liquid_gallon = US_liquid_gallon" + ,"quart = gallon / 4 = liquid_quart = US_liquid_quart" + ,"pint = quart / 2 = pt = liquid_pint = US_liquid_pint" + ,"cup = pint / 2 = liquid_cup = US_liquid_cup" + ,"gill = cup / 2 = liquid_gill = US_liquid_gill" + ,"floz = gill / 4 = fluid_ounce = US_fluid_ounce = US_liquid_ounce" + ,"imperial_bushel = 36.36872 * liter = UK_bushel" + ,"imperial_gallon = imperial_bushel / 8 = UK_gallon" + ,"imperial_quart = imperial_gallon / 4 = UK_quart" + ,"imperial_pint = imperial_quart / 2 = UK_pint" + ,"imperial_cup = imperial_pint / 2 = UK_cup" + ,"imperial_gill = imperial_cup / 2 = UK_gill" + ,"imperial_floz = imperial_gill / 5 = UK_fluid_ounce = imperial_fluid_ounce" + ,"barrel = 42 * gallon = bbl" + ,"tablespoon = floz / 2 = tbsp = Tbsp = Tblsp = tblsp = tbs = Tbl" + ,"teaspoon = tablespoon / 3 = tsp" + ,"peck = bushel / 4 = pk" + ,"fluid_dram = floz / 8 = fldr = fluidram" + ,"firkin = barrel / 4" + ] + +-- otherDefinitions :: String +-- otherDefinitions = unlines [ +-- -- Heat +-- "RSI = degK * meter ** 2 / watt" +-- ,"clo = 0.155 * RSI = clos" +-- ,"R_value = foot ** 2 * degF * hour / btu" + +-- -- Temperature +-- ,"degR = 9 / 5 * degK; offset: 0 = rankine" +-- ,"degC = degK; offset: 273.15 = celsius = C" +-- ,"degF = 9 / 5 * degK; offset: 255.372222 = fahrenheit = F" + +-- ] diff --git a/library/Data/Quantities/DefinitionParser.hs b/library/Data/Quantities/DefinitionParser.hs new file mode 100644 --- /dev/null +++ b/library/Data/Quantities/DefinitionParser.hs @@ -0,0 +1,107 @@ +-- | Uses parsec to parse definition lines. +module Data.Quantities.DefinitionParser where + +import Control.Applicative ((<*)) +import Text.ParserCombinators.Parsec + +import Data.Quantities.Data +import Data.Quantities.ExprParser (parseMultExpr) + +-- | Parse multiline string of definitions (say, from a file) into a +-- list of definitions. +parseDefinitions :: String -> [Definition] +parseDefinitions input = case parse parseDefinitions' "Input File Parser" input of + Left err -> error (show err) >> [] + Right val -> val + +-- | Parsec parser for definitions. +parseDefinitions' :: Parser [Definition] +parseDefinitions' = many parseDef <* eof + +-- | Parse any definition line +parseDef :: Parser Definition +parseDef = do + _ <- spaces + -- skipMany comment + optional $ many $ char '\n' + line <- try parseDefLine <|> try parseBaseLine <|> parsePrefixLine + spaces + -- skipMany comment + optional $ many $ char '\n' + return line + +-- comment :: Parser String +-- comment = char '#' >> many (noneOf "\n") + +-- | Custom eol parsec parser. +eol :: Parser Char +eol = char '\n' + +-- | Parse a line containing unit definition +-- Ex: minute = 60 s = min +parseDefLine :: Parser Definition +parseDefLine = do + (UnitDefinition s e []) <- parseUnitDef + syns <- many (try parseSynonym) + return $ UnitDefinition s e syns + +-- | Parses a unit definition. Example: foot = 12 in = ft = feet +parseUnitDef :: Parser Definition +parseUnitDef = do + sym <- parseSymbol <* spaces <* char '=' + quant <- parseMultExpr + spaces + -- skipMany comment + return $ UnitDefinition sym quant [] + +-- | Parses the synonyms at the end of a base or unit definition. +parseSynonym :: Parser Symbol +parseSynonym = spaces >> char '=' >> spaces >> parseSymbol <* spaces + + +-- | Parse line containing base definition. +-- Ex: meter = [length] = m +parseBaseLine :: Parser Definition +parseBaseLine = do + (sym, f) <- parseBase + syns <- many (try parseSynonym) + return $ BaseDefinition sym f syns + +-- | Parse the base of a base definition. Example: [length] -> length +parseBase :: Parser (Symbol, Symbol) +parseBase = do + sym <- parseSymbol <* spaces <* char '=' + b <- spaces >> char '[' >> option "" parseSymbol <* char ']' + spaces + -- skipMany comment + return (sym, b) + +-- | Parse line containing prefix definition +-- Ex: milli- = 1e-3 = m- +parsePrefixLine :: Parser Definition +parsePrefixLine = do + (p, f) <- parsePrefix + syns <- many (try parsePrefixSynonym) + return $ PrefixDefinition p f syns + +-- | Parse the prefix part of a prefix definition. Example: yocto- -> yocto +parsePrefix :: Parser (Symbol, Double) +parsePrefix = do + pre <- many1 letter <* char '-' <* spaces <* char '=' + facQuant <- spaces >> parseMultExpr + spaces + if null (units' facQuant) then + return (pre, magnitude facQuant) + else fail "No units allowed in prefix definitions" + +-- | Parse the synonyms for a prefix definition. +parsePrefixSynonym :: Parser Symbol +parsePrefixSynonym = spaces >> char '=' >> spaces >> parseSymbol <* char '-' <* spaces + + +-- | Parse a symbol for a unit +parseSymbol :: Parser Symbol +parseSymbol = do + letter' <- letter + rest <- many (alphaNum <|> char '_') + return $ letter' : rest diff --git a/library/Data/Quantities/Definitions.hs b/library/Data/Quantities/Definitions.hs new file mode 100644 --- /dev/null +++ b/library/Data/Quantities/Definitions.hs @@ -0,0 +1,90 @@ +-- | This module builds a Definitions object from a string. +module Data.Quantities.Definitions where + +import Control.Applicative ((<$>)) +import Control.Monad.State +import Data.Bits (xor) +import Data.List (foldl') +import qualified Data.Map as M +import qualified Data.Set as S + +import Data.Quantities.Convert (convertBase') +import Data.Quantities.Data +import Data.Quantities.DefinitionParser (parseDefinitions) +import Data.Quantities.ExprParser (preprocessQuantity) + +-- | Convert string of definitions into 'Definitions' structure. See source +-- code for 'Data.Quantities.defaultDefString' for an example. +readDefinitions :: String -> Either (QuantityError Double) Definitions +readDefinitions s = addDefinitionsHash s <$> d + where d = makeDefinitions (parseDefinitions s) + +-- | Monad used for addDefinition. +type DefineMonad = StateT Definitions (Either (QuantityError Double)) + +-- | Converts a list of definitions to the Definitions data structure. Modifies +-- an emptyDefinitions object by combining the incremental additions of each +-- Definition. +makeDefinitions :: [Definition] -> Either (QuantityError Double) Definitions +makeDefinitions ds = execStateT (mapM addDefinition ds) emptyDefinitions + +-- | Add one definition to the definitions. Creates a new Definitions object +-- using the information in the Definition, and then unions the Definitions in +-- the state monad with this new object. +addDefinition :: Definition -> DefineMonad () + +addDefinition (PrefixDefinition sym fac syns) = do + d <- get + let newd = emptyDefinitions { + prefixes = sym : syns + , prefixValues = M.singleton sym fac + , prefixSynonyms = M.fromList $ zip (sym : syns) (repeat sym) } + defCheck = checkDefined (sym : syns) (prefixes d) + if null defCheck + then put $ d `unionDefinitions` newd + else lift . Left . PrefixAlreadyDefinedError $ head defCheck ++ "-" + +addDefinition (BaseDefinition sym utype syns) = do + d <- get + let defCheck = checkDefined (sym : syns) (unitsList d) + if null defCheck + then put $ d `unionDefinitions` emptyDefinitions { + bases = M.singleton sym (1, [SimpleUnit sym "" 1]) + , unitsList = sym : syns + , synonyms = M.fromList $ zip (sym : syns) (repeat sym) + , unitTypes = M.singleton sym utype } + else lift . Left $ UnitAlreadyDefinedError (head defCheck) + +addDefinition (UnitDefinition sym q syns) = do + -- First, we preprocess the quantity so all units are base units and + -- prefixes are preprocessed. Then we do the standard Definitions + -- modification like prefix and base definitions. + d <- get + let pq = preprocessQuantity d q + defCheck = checkDefined (sym : syns) (unitsList d) + if null defCheck + then case pq of + (Right pq') -> do + let (Quantity baseFac baseUnits) = convertBase' d pq' + put $ d `unionDefinitions` emptyDefinitions { + bases = M.singleton sym (baseFac, sUnits baseUnits) + , synonyms = M.fromList $ zip (sym : syns) (repeat sym) + , unitsList = sym : syns } + (Left err) -> lift . Left $ err + else lift . Left $ UnitAlreadyDefinedError $ head defCheck + + +-- | Computes intersection of two lists +checkDefined :: [Symbol] -> [Symbol] -> [Symbol] +checkDefined a b = S.toList $ S.intersection (S.fromList a) (S.fromList b) + + +-- | Variant of the DJB2 hash; +hash :: String -> Int +hash = foldl' (\h c -> 33*h `xor` fromEnum c) 5381 + +-- | Add a hash of the definitions string to a group of Definitions. Meant to +-- be the last step, after definitions are created. Used for Definitions +-- comparison. +addDefinitionsHash :: String -> Definitions -> Definitions +addDefinitionsHash s d = d { defStringHash = hash s } diff --git a/library/Data/Quantities/ExprParser.hs b/library/Data/Quantities/ExprParser.hs new file mode 100644 --- /dev/null +++ b/library/Data/Quantities/ExprParser.hs @@ -0,0 +1,237 @@ +-- | Parse expressions with numbers and units. +-- +-- This module provides a basic expression grammar that parses numbers +-- and units. +module Data.Quantities.ExprParser where + +import Control.Applicative ((<*>), (<$>), (*>), (<*)) +import Data.Either (partitionEithers) +import qualified Data.Map as M +import Numeric (readFloat) +import Text.ParserCombinators.Parsec + +import Data.Quantities.Convert (addQuants, subtractQuants, convert) +import Data.Quantities.Data + +-- | Alternate definition for spaces. Just actual spaces. +spaces' :: Parser String +spaces' = many $ char ' ' + +-- | Parse quantity expression; addition and subtraction allowed. +parseExprQuant :: Definitions -> String -> + Either (QuantityError Double) (Quantity Double) +parseExprQuant d input = case parse (parseExpr d) "arithmetic" input of + Left err -> Left $ ParserError $ show err + Right val -> val + +-- | Simple type used for shorthand +type EQuant = Either (QuantityError Double) (Quantity Double) + +-- | Using already compiled definitions, parse expression. Also allows for +-- expressions like "exp1 => exp2" in the middle, which converts the quantity +-- exp1 into the units of the quantity exp2. +parseExpr :: Definitions -> Parser EQuant +parseExpr d = (try (parseConvertExpr d) <|> parseSingle) <* eof + where parseSingle = spaces >> parseExpr' d <* spaces + +-- | Parser that accepts "=>" in between two expressions. +parseConvertExpr :: Definitions -> Parser EQuant +parseConvertExpr d = do + _ <- spaces' + exp1 <- parseExpr' d <* spaces + exp2 <- string "=>" >> spaces >> parseExpr' d + _ <- spaces' + return $ do + e1 <- exp1 + e2 <- exp2 + u2 <- units <$> exp2 + case magnitude e2 of + 1.0 -> convert e1 u2 + _ -> Left $ ScalingFactorError e2 + +parseExpr', parseTerm :: Definitions -> Parser EQuant +parseFactor, parseExpt, parseNestedExpr :: Definitions -> Parser EQuant +parseExpr' d = try (parseTermOp d) <|> parseTerm d +parseTerm d = try (parseFactorOp d) <|> parseFactor d +parseFactor d = try (parseExptOp d) <|> parseExpt d +parseExpt d = try (parseNestedExpr d) <|> parseESymbolNum d +parseNestedExpr d = spaces' >> char '(' *> spaces' >> + parseExpr' d + <* spaces' <* char ')' <* spaces' "parseNested" + +parseExptOp, parseTermOp, parseFactorOp :: Definitions -> Parser EQuant +parseExptOp d = parseExpt d `chainl1` exptOp +parseTermOp d = parseTerm d `chainl1` addOp +parseFactorOp d = parseFactor d `chainl1` mulOp + + +exptOp, addOp, mulOp :: Parser (EQuant -> EQuant -> EQuant) +addOp = try parseAdd <|> parseSubtract "addOp" + where parseAdd = char '+' >> spaces' >> return addEQuants + parseSubtract = char '-' >> spaces' >> return subtractEQuants +mulOp = try parseTimes <|> try parseDiv <|> parseImplicitTimes "mulOp" + where parseTimes = char '*' >> spaces' >> return multiplyEQuants + parseDiv = divOp >> spaces' >> return divideEQuants + where divOp = try (string "/") <|> string "per " + parseImplicitTimes = return multiplyEQuants +exptOp = try (opChoice >> spaces' >> return exptEQuants) "expOp" + where opChoice = string "^" <|> string "**" + +-- | Modification of addQuants to account for Either QuantityError Quantity. +addEQuants :: EQuant -> EQuant -> EQuant +addEQuants (Right a) (Right b) = addQuants a b +addEQuants (Left a) _ = Left a +addEQuants _ (Left b) = Left b + +-- | Modification of subtractQuants to account for Either QuantityError Quantity. +subtractEQuants :: EQuant -> EQuant -> EQuant +subtractEQuants (Right a) (Right b) = subtractQuants a b +subtractEQuants (Left a) _ = Left a +subtractEQuants _ (Left b) = Left b + +-- | Modification of multiplyQuants to account for Either QuantityError Quantity. +multiplyEQuants :: EQuant -> EQuant -> EQuant +multiplyEQuants (Right a) (Right b) = Right $ multiplyQuants a b +multiplyEQuants (Left a) _ = Left a +multiplyEQuants _ (Left b) = Left b + +-- | Modification of divideQuants to account for Either QuantityError Quantity. +divideEQuants :: EQuant -> EQuant -> EQuant +divideEQuants (Right a) (Right b) = Right $ divideQuants a b +divideEQuants (Left a) _ = Left a +divideEQuants _ (Left b) = Left b + +-- | Modification of exptQuants to account for Either QuantityError Quantity. +-- Returns error if dimensional quantity used in exponent. +exptEQuants :: EQuant -> EQuant -> EQuant +exptEQuants (Left a) _ = Left a +exptEQuants _ (Left b) = Left b +exptEQuants (Right q) (Right (Quantity y (CompoundUnit _ []))) = Right $ exptQuants q y +exptEQuants a b = Left $ ParserError $ "Used non-dimensionless exponent in " ++ showq + where showq = unwords ["(", show a, ") ** (", show b, ")"] + +-- | Modification of parseSymbolNum to handle parsing errors. +parseESymbolNum :: Definitions -> Parser EQuant +parseESymbolNum d = try (parseENum d) <|> parseESymbol d + +-- | Parses a symbol and then parses a prefix form that symbol. +parseESymbol :: Definitions -> Parser EQuant +parseESymbol d = do + q <- parseSymbol' + return $ preprocessQuantity d q + +-- | Parse a number and insert the given definitions into the CompoundUnit. +parseENum :: Definitions -> Parser EQuant +parseENum d = do + q <- parseNum + return $ Right $ q { units = (units q) { defs = d } } + +-- | Parses out prefixes and aliases from quantity's units. +preprocessQuantity :: Definitions -> Quantity Double -> EQuant +preprocessQuantity d (Quantity x us) + | null errs = Right $ Quantity x (CompoundUnit d us') + | otherwise = Left $ head errs + where ppUnits = map (preprocessUnit d) (sUnits us) + (errs, us') = partitionEithers ppUnits + +-- | Parses prefix and alias, if applicable, from a SimpleUnit. +preprocessUnit :: Definitions -> SimpleUnit -> Either (QuantityError Double) SimpleUnit +preprocessUnit d (SimpleUnit s _ p) + | rs `elem` unitsList d = Right $ SimpleUnit ns np p + | otherwise = Left $ UndefinedUnitError s + where (rp, rs) = prefixParser d s + np = prefixSynonyms d M.! rp + ns = synonyms d M.! rs + +-- | Try to parse a prefix from a symbol. Otherwise, just return the symbol. +prefixParser :: Definitions -> String -> (String, String) +prefixParser d input = if input `elem` unitsList d + then ("", input) + else case parse (prefixParser' d) "arithmetic" input of + Left _ -> ("", input) + Right val -> splitAt (length val) input + +-- | Helper function for prefixParser that is a Parsec parser. +prefixParser' :: Definitions -> Parser String +prefixParser' d = do + pr <- choice $ map (try . string) (prefixes d) + _ <- choice $ map (try . string) (unitsList d) + return pr + +-- | Converts string to a Quantity using an expression grammar parser. This +-- parser does not parser addition or subtraction, and is used for unit +-- definitions. +parseMultExpr :: Parser (Quantity Double) +parseMultExpr = spaces' >> parseMultExpr' <* spaces' + +parseMultExpr', parseMultFactor, parseMultExpt, parseMultNestedExpr :: Parser (Quantity Double) +parseMultExpr' = try parseMultFactorOp <|> parseMultFactor +parseMultFactor = try parseMultExptOp <|> parseMultExpt +parseMultExpt = try parseMultNestedExpr <|> parseSymbolNum +parseMultNestedExpr = spaces' >> char '(' *> spaces' >> + parseMultExpr' + <* spaces' <* char ')' <* spaces' "parseNested" + + +parseMultExptOp, parseMultFactorOp :: Parser (Quantity Double) +parseMultExptOp = parseMultExpt `chainl1` exptMultOp +parseMultFactorOp = parseMultFactor `chainl1` mulMultOp + +exptMultOp, mulMultOp :: Parser (Quantity Double -> Quantity Double -> Quantity Double) +mulMultOp = try parseTimes <|> try parseDiv <|> parseImplicitTimes "mulMultOp" + where parseTimes = char '*' >> spaces' >> return multiplyQuants + parseDiv = char '/' >> spaces' >> return divideQuants + parseImplicitTimes = return multiplyQuants +exptMultOp = try (opChoice >> spaces' >> return exptMultQuants') "expMultOp" + where opChoice = string "^" <|> string "**" + +exptMultQuants' :: (Quantity Double -> Quantity Double -> Quantity Double) +exptMultQuants' q (Quantity y (CompoundUnit _ [])) = exptQuants q y +exptMultQuants' a b = error $ "Used non-dimensionless exponent in " ++ showq + where showq = unwords ["(", show a, ") ** (", show b, ")"] + +-- | Parse either a symbol or a number. +parseSymbolNum :: Parser (Quantity Double) +parseSymbolNum = try parseNum <|> parseSymbol' + +-- | Parse a symbol with an optional negative sign. A symbol can contain +-- alphanumeric characters and the character '_'. +parseSymbol' :: Parser (Quantity Double) +parseSymbol' = do + neg <- option "" $ string "-" + symf <- letter + rest <- many (alphaNum <|> char '_') + _ <- spaces' + return $ baseQuant (timesSign neg 1) [SimpleUnit (symf : rest) "" 1] + +-- | Parent function for parseNum' to parse a number. +parseNum :: Parser (Quantity Double) +parseNum = do + num <- parseNum' + return $ baseQuant num [] + +-- | Meat of number parser. Parse digits with an optional negative sign and +-- optional exponential. For example, -5.2e4. +parseNum' :: Parser Double +parseNum' = do + neg <- option "" $ string "-" + whole <- many1 digit + decimal <- option "" $ (:) <$> char '.' <*> many1 digit + exponential <- option "" parseExponential + _ <- spaces' + return $ timesSign neg $ fst $ head $ readFloat $ whole ++ decimal ++ exponential + +-- | Parses just the exponential part of a number. For example, parses "4" from +-- "-5.2e4". +parseExponential :: Parser String +parseExponential = do + e <- string "e" + neg <- option "" $ string "+" <|> string "-" + pow <- many1 digit + return $ e ++ neg ++ pow + +-- | Negate a number if the first argument is a negative sign. +timesSign :: String -> Double -> Double +timesSign sign x + | sign == "-" = -x + | otherwise = x diff --git a/quantities.hs b/quantities.hs new file mode 100644 --- /dev/null +++ b/quantities.hs @@ -0,0 +1,19 @@ +import System.Environment +import System.Exit + +import Data.Quantities + +main :: IO () +main = getArgs >>= parse + +parse :: [String] -> IO () +parse ["-h"] = usage >> exit +parse ["-v"] = version >> exit +parse [] = usage >> exit +parse [s] = putStr $ (++ "\n") $ either show show $ fromString s +parse _ = usage >> Main.die + +usage = putStrLn "Usage: quantities [-vh] expression" +version = putStrLn "Haskell quantities 0.3.0" +exit = exitSuccess +die = exitWith (ExitFailure 1) diff --git a/test-suite/DocCoverage.hs b/test-suite/DocCoverage.hs new file mode 100644 --- /dev/null +++ b/test-suite/DocCoverage.hs @@ -0,0 +1,25 @@ +module Main (main) where + +import Data.List (genericLength) +import Data.Maybe (catMaybes) +import System.Exit (exitFailure, exitSuccess) +import System.Process (readProcess) +import Text.Regex (matchRegex, mkRegex) + +average :: (Fractional a, Real b) => [b] -> a +average xs = realToFrac (sum xs) / genericLength xs + +expected :: Fractional a => a +expected = 90 + +main :: IO () +main = do + output <- readProcess "cabal" ["haddock"] "" + if average (match output) >= expected + then exitSuccess + else putStr output >> exitFailure + +match :: String -> [Int] +match = fmap read . concat . catMaybes . fmap (matchRegex pattern) . lines + where + pattern = mkRegex "^ *([0-9]*)% " diff --git a/test-suite/DocTest.hs b/test-suite/DocTest.hs new file mode 100644 --- /dev/null +++ b/test-suite/DocTest.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = glob "library/**/*.hs" >>= doctest diff --git a/test-suite/HLint.hs b/test-suite/HLint.hs new file mode 100644 --- /dev/null +++ b/test-suite/HLint.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import Language.Haskell.HLint (hlint) +import System.Exit (exitFailure, exitSuccess) + +arguments :: [String] +arguments = + [ "library" + , "test-suite" + ] + +main :: IO () +main = do + hints <- hlint arguments + if null hints then exitSuccess else exitFailure diff --git a/test-suite/Spec.hs b/test-suite/Spec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}