diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,7 +1,15 @@ quantities changelog ==================== -0.1 (unreleased) + +0.2 (unreleased) +---------------- + +- Can handle arithmetical expressions in fromString +- Added support for user-defined definitions + + +0.1 (3-31-2014) ---------------- - Full implementation of multiplicative dimensional quantities (no offsets yet diff --git a/library/Data/Quantities.hs b/library/Data/Quantities.hs --- a/library/Data/Quantities.hs +++ b/library/Data/Quantities.hs @@ -6,7 +6,7 @@ -- 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 simplifcation. +-- doing so uses automatic unit conversion and simplification. module Data.Quantities @@ -15,11 +15,11 @@ -- $constructors fromString , unitsFromString + , Definitions , Quantity , magnitude , units - , CompositeUnit - , SimpleUnit + , CompoundUnit -- * Conversion -- $conversion , convert @@ -32,24 +32,30 @@ , multiplyQuants , divideQuants , exptQuants + -- * Custom definitions + -- $custom-defs + , fromString' + , readDefinitions + , defaultDefString -- * Error type , QuantityError(..) , QuantityComputation - , comp ) where -import Data.Quantities.Constructors (fromString, unitsFromString) +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) -- $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 'Data.Quantities.DefaultUnits.defaultDefString'. +-- /source code/ for 'defaultDefString'. -- $conversion -- @@ -85,8 +91,34 @@ -- >>> x `exptQuants` 0 -- 1.0 -comp :: QuantityComputation Quantity -comp = do - x <- fromString "BADUNIT" - y <- unitsFromString "m/s" - convert x y + +-- $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@. +-- +-- > myDefString = defaultDefString ++ "\n" ++ "metric_foot = 300mm" +-- > (Right d') = readDefinitions myDefString +-- > 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. +-- +-- > (Right m) = fromString "m" +-- > (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 --- a/library/Data/Quantities/Constructors.hs +++ b/library/Data/Quantities/Constructors.hs @@ -1,39 +1,49 @@ module Data.Quantities.Constructors where -import Data.Quantities.Data (Definitions, CompositeUnit, Quantity(units), - QuantityError(..)) +import Data.Quantities.Data import Data.Quantities.DefaultUnits (defaultDefString) -import Data.Quantities.DefinitionParser (readDefinitions) -import Data.Quantities.Definitions (makeDefinitions, preprocessQuantity) +import Data.Quantities.Definitions (readDefinitions) import Data.Quantities.ExprParser (parseExprQuant) defaultDefinitions :: Either QuantityError Definitions -defaultDefinitions = makeDefinitions $ readDefinitions defaultDefString +defaultDefinitions = readDefinitions defaultDefString d :: Definitions (Right d) = defaultDefinitions --- | Create a Quantity by parsing a string. Uses an --- 'UndefinedUnitError' for undefined units. +-- | 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 +-- +-- Make sure not to use dimensional quantities in exponents. +-- +-- >>> fromString "m ** 2" +-- Right 1.0 meter ** 2.0 +-- >>> fromString "m ** (2s)" +-- Left (ParserError "Used non-dimensionless exponent in ( Right 1.0 meter ) ** ( Right 2.0 second )") fromString :: String -> Either QuantityError Quantity -fromString s = - case rawq of - (Left err) -> Left $ ParserError err - (Right q) -> case preprocessQuantity d q of - (Left err) -> Left err - (Right q') -> Right q' - where rawq = parseExprQuant s +fromString = parseExprQuant d +-- | Create quantities with custom definitions. +-- +-- > (Right d) = readDefinitions myDefString +-- > myFromString = fromString' d +-- +-- >>> myFromString "25 m/s" +-- Right 25.0 meter / second +fromString' :: Definitions -> String -> Either QuantityError Quantity +fromString' = parseExprQuant + -- | Parse units from a string. Equivalent to @fmap units . fromString@ -- -- >>> unitsFromString "N * s" -- Right [newton,second] -unitsFromString :: String -> Either QuantityError CompositeUnit +unitsFromString :: String -> Either QuantityError CompoundUnit unitsFromString = fmap units . fromString diff --git a/library/Data/Quantities/Convert.hs b/library/Data/Quantities/Convert.hs --- a/library/Data/Quantities/Convert.hs +++ b/library/Data/Quantities/Convert.hs @@ -3,18 +3,21 @@ import Data.List (sort) import qualified Data.Map as M -import Data.Quantities.Data (Quantity(..), CompositeUnit, SimpleUnit(..), Definitions(..) - ,multiplyQuants, QuantityError(..)) +import Data.Quantities.Data unityQuant :: Definitions -> Quantity -unityQuant = Quantity 1 [] +unityQuant d = Quantity 1 (CompoundUnit d []) -- | Convert quantity to given units. -- -- >>> convert <$> fromString "m" <*> unitsFromString "ft" -- Right (Right 3.280839895013123 foot) -convert :: Quantity -> CompositeUnit -> Either QuantityError Quantity -convert x = convert' (defs x) x +convert :: Quantity -> CompoundUnit -> Either QuantityError Quantity +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. @@ -22,34 +25,35 @@ -- >>> convertBase <$> fromString "newton" -- Right 1000.0 gram meter / second ** 2.0 convertBase :: Quantity -> Quantity -convertBase x = convertBase' (defs x) x +convertBase x = convertBase' (defs' x) x -- | Convert quantity to given units. -convert' :: Definitions -> Quantity -> CompositeUnit -> Either QuantityError Quantity +convert' :: Definitions -> Quantity -> CompoundUnit -> Either QuantityError Quantity convert' d q us' - | dimq /= dimus = Left $ DimensionalityError dimq dimus - | otherwise = Right $ Quantity (mb/mb') us' d - where (Quantity mb _ _) = convertBase' d q - (Quantity mb' _ _) = toBase d us' - dimq = dimensionality' d (units q) - dimus = dimensionality' d us' + | dimq /= dimus = Left $ DimensionalityError (CompoundUnit d dimq) (CompoundUnit d dimus) + | otherwise = Right $ Quantity (mb/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' :: Definitions -> Quantity -> Quantity -convertBase' d (Quantity m us _) = Quantity (m*mb) ub d - where (Quantity mb ub _) = toBase d us +convertBase' d (Quantity m us) = Quantity (m*mb) ub + where (Quantity mb ub) = toBase d (sUnits us) -- | Converts a composite unit to its base quantity -toBase :: Definitions -> CompositeUnit -> Quantity +toBase :: Definitions -> [SimpleUnit] -> Quantity toBase d = foldr (multiplyQuants . simpleToBase d) (unityQuant d) -- | Converts a simple unit to its base quantity. simpleToBase :: Definitions -> SimpleUnit -> Quantity -simpleToBase d (SimpleUnit sym pre pow) = Quantity m us d +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 @@ -59,12 +63,13 @@ -- -- >>> dimensionality <$> fromString "newton" -- Right [length,mass,time ** -2.0] -dimensionality :: Quantity -> CompositeUnit -dimensionality q = dimensionality' (defs q) (units q) +dimensionality :: Quantity -> CompoundUnit +dimensionality q = CompoundUnit (defs' q) dimUnits + where dimUnits = dimensionality' (defs' q) (units' q) -dimensionality' :: Definitions -> CompositeUnit -> CompositeUnit +dimensionality' :: Definitions -> [SimpleUnit] -> [SimpleUnit] dimensionality' d us = sort $ map dim ub - where (Quantity _ ub _) = toBase d us + where ub = units' $ toBase d us dim (SimpleUnit sym _ pow) = SimpleUnit (unitTypes d M.! sym) "" pow @@ -82,7 +87,7 @@ linearQuants :: (Double -> Double -> Double) -> Quantity -> Quantity -> Either QuantityError Quantity -linearQuants f (Quantity m1 u1 d) q2 = case q of - (Right q') -> Right $ Quantity (f m1 (magnitude q')) u1 d +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 --- a/library/Data/Quantities/Data.hs +++ b/library/Data/Quantities/Data.hs @@ -13,7 +13,7 @@ -- > SimpleUnit { symbol = "meter", prefix = "milli", power = 2.0 } data SimpleUnit = SimpleUnit { symbol :: String , prefix :: String - , power :: Double} deriving (Eq, Ord) + , power :: Double } deriving (Eq, Ord) instance Show SimpleUnit where show (SimpleUnit s pr p) @@ -22,14 +22,14 @@ where sym = pr ++ s --- | Collection of SimpleUnits. Represents combination of simple --- units. -type CompositeUnit = [SimpleUnit] +data CompoundUnit = CompoundUnit { defs :: Definitions + , sUnits :: [SimpleUnit] + } deriving (Eq, Ord) --- | Used to show composite units. -showCompUnit :: CompositeUnit -> String -showCompUnit = unwords . map showCompUnit' . showSort +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' (SimpleUnit s pr p) @@ -46,37 +46,44 @@ -- -- >>> magnitude <$> fromString "100 N * m" -- Right 100.0 - , units :: CompositeUnit + , units :: CompoundUnit -- ^ Units associated with quantity. -- -- >>> units <$> fromString "3.4 m/s^2" -- Right [meter,second ** -2.0] - , defs :: Definitions } deriving (Ord) + } deriving (Ord) +-- | Convenience function to extract SimpleUnit collection from Quantity's +-- CompoundUnit. +units' :: Quantity -> [SimpleUnit] +units' = sUnits . units + +-- | Convenience function to extract Definitions from Quantity's CompoundUnit. +defs' :: Quantity -> Definitions +defs' = defs . units + instance Show Quantity where - show (Quantity m us _) = show m ++ " " ++ showCompUnit us + show (Quantity m us) = show m ++ " " ++ show us + +-- | Convenience function to make quantity with no definitions. +baseQuant :: Double -> [SimpleUnit] -> Quantity +baseQuant m us = Quantity m (CompoundUnit emptyDefinitions us) + -- | Sort units but put negative units at end. -showSort :: CompositeUnit -> CompositeUnit +showSort :: [SimpleUnit] -> [SimpleUnit] showSort c = pos ++ neg where (pos, neg) = partition (\q -> power q > 0) c instance Eq Quantity where - (Quantity m1 u1 _) == (Quantity m2 u2 _) = m1 == m2 && sort u1 == sort u2 + (Quantity m1 u1) == (Quantity m2 u2) = m1 == m2 && sort (sUnits u1) == sort (sUnits u2) --- | Quantity without definitions. -baseQuant :: Double -> CompositeUnit -> Quantity -baseQuant m u = Quantity m u emptyDefinitions - -fromDefinitions :: Definitions -> Double -> CompositeUnit -> Quantity -fromDefinitions d m u = Quantity m u d - -- | Custom error type data QuantityError = UndefinedUnitError String -- ^ Used when trying to parse an undefined unit. - | DimensionalityError CompositeUnit CompositeUnit + | DimensionalityError CompoundUnit CompoundUnit -- ^ Used when converting units that do not have the same -- dimensionality (example: convert meter to second). | UnitAlreadyDefinedError String @@ -87,10 +94,13 @@ -- already defined. | ParserError String -- ^ Used when a string cannot be parsed. + | DifferentDefinitionsError CompoundUnit CompoundUnit + -- ^ Used when two quantities come from different + -- Definitions. deriving (Show, Eq) --- | Computation monad that propagates 'QuantityError's. Some examples: +-- | Useful for monadic computations with 'QuantityError's. Some examples: -- -- > computation :: QuantityComputation Quantity -- > computation = do @@ -111,9 +121,10 @@ -- | Combines equivalent units and removes units with powers of zero. reduceUnits :: Quantity -> Quantity -reduceUnits q = q { units = reduceUnits' (units q) } +reduceUnits q = q { units = newUnits } + where newUnits = (units q) { sUnits = reduceUnits' (units' q) } -reduceUnits', removeZeros :: CompositeUnit -> CompositeUnit +reduceUnits', removeZeros :: [SimpleUnit] -> [SimpleUnit] reduceUnits' = removeZeros . reduceComp . sort where reduceComp [] = [] reduceComp (SimpleUnit x pr1 p1 : SimpleUnit y pr2 p2: xs) @@ -126,7 +137,7 @@ removeZeros (SimpleUnit _ _ 0.0 : xs) = removeZeros xs removeZeros (x:xs) = x : removeZeros xs -invertUnits :: CompositeUnit -> CompositeUnit +invertUnits :: [SimpleUnit] -> [SimpleUnit] invertUnits = map invertSimpleUnit -- | Inverts unit by negating the power field. @@ -135,20 +146,21 @@ -- | Multiplies two quantities. multiplyQuants :: Quantity -> Quantity -> Quantity -multiplyQuants x y = reduceUnits $ Quantity mag newUnits (defs x) +multiplyQuants x y = reduceUnits $ Quantity mag newUnits where mag = magnitude x * magnitude y - newUnits = units x ++ units y + newUnits = (units x) { sUnits = units' x ++ units' y } -- | Divides two quantities. divideQuants :: Quantity -> Quantity -> Quantity -divideQuants x y = reduceUnits $ Quantity mag newUnits (defs x) +divideQuants x y = reduceUnits $ Quantity mag newUnits where mag = magnitude x / magnitude y - newUnits = units x ++ invertUnits (units y) + newUnits = (units x) { sUnits = units' x ++ invertUnits (units' y) } -- | Exponentiates a quantity with a double. exptQuants :: Quantity -> Double -> Quantity -exptQuants (Quantity x u d) y = reduceUnits $ Quantity (x**y) (expUnits u) d +exptQuants (Quantity x u) y = reduceUnits $ Quantity (x**y) newUnits where expUnits = map (\(SimpleUnit s pr p) -> SimpleUnit s pr (p*y)) + newUnits = u { sUnits = expUnits (sUnits u) } data Definition = PrefixDefinition { defPrefix :: Symbol @@ -162,14 +174,35 @@ , defSynonyms :: [Symbol]} deriving (Show, Eq, Ord) -data Definitions = Definitions { bases :: M.Map String (Double, CompositeUnit) +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 - , unitTypes :: M.Map String String } deriving (Show, Eq, Ord) + -- ^ 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 + emptyDefinitions :: Definitions emptyDefinitions = Definitions { bases = M.empty , synonyms = M.empty @@ -177,7 +210,8 @@ , prefixes = [] , prefixValues = M.fromList [("", 1)] , prefixSynonyms = M.fromList [("", "")] - , unitTypes = M.empty } + , unitTypes = M.empty + , defStringHash = -1 } -- | Combine two Definitions structures @@ -189,4 +223,5 @@ , 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 } + , unitTypes = unitTypes d1 `M.union` unitTypes d2 + , defStringHash = -1 } diff --git a/library/Data/Quantities/DefaultUnits.hs b/library/Data/Quantities/DefaultUnits.hs --- a/library/Data/Quantities/DefaultUnits.hs +++ b/library/Data/Quantities/DefaultUnits.hs @@ -1,7 +1,7 @@ module Data.Quantities.DefaultUnits (defaultDefString) where -- | View the source code for this declaration to see what units and prefixes --- are defined. +-- 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 diff --git a/library/Data/Quantities/DefinitionParser.hs b/library/Data/Quantities/DefinitionParser.hs --- a/library/Data/Quantities/DefinitionParser.hs +++ b/library/Data/Quantities/DefinitionParser.hs @@ -1,27 +1,20 @@ module Data.Quantities.DefinitionParser where -import Control.Applicative ((<$>), (<*)) -import System.Environment +import Control.Applicative ((<*)) import Text.ParserCombinators.Parsec -import Data.Quantities.Data (Definition (..), Symbol, units, magnitude) -import Data.Quantities.ExprParser (parseExpr) - - -main :: IO () -main = do - defs <- readDefinitions <$> head <$> getArgs - print defs +import Data.Quantities.Data +import Data.Quantities.ExprParser (parseMultExpr) -- | Parse multiline string of definitions (say, from a file) into a -- list of definitions. -readDefinitions :: String -> [Definition] -readDefinitions input = case parse readDefinitions' "Input File Parser" input of +parseDefinitions :: String -> [Definition] +parseDefinitions input = case parse parseDefinitions' "Input File Parser" input of Left err -> error (show err) >> [] Right val -> val -readDefinitions' :: Parser [Definition] -readDefinitions' = many parseDef <* eof +parseDefinitions' :: Parser [Definition] +parseDefinitions' = many parseDef <* eof -- | Parse any definition line parseDef :: Parser Definition @@ -52,7 +45,7 @@ parseUnitDef :: Parser Definition parseUnitDef = do sym <- parseSymbol <* spaces <* char '=' - quant <- parseExpr + quant <- parseMultExpr spaces -- skipMany comment return $ UnitDefinition sym quant [] @@ -88,9 +81,9 @@ parsePrefix :: Parser (Symbol, Double) parsePrefix = do pre <- many1 letter <* char '-' <* spaces <* char '=' - facQuant <- spaces >> parseExpr + facQuant <- spaces >> parseMultExpr spaces - if null (units facQuant) then + if null (units' facQuant) then return (pre, magnitude facQuant) else fail "No units allowed in prefix definitions" diff --git a/library/Data/Quantities/Definitions.hs b/library/Data/Quantities/Definitions.hs --- a/library/Data/Quantities/Definitions.hs +++ b/library/Data/Quantities/Definitions.hs @@ -1,14 +1,23 @@ module Data.Quantities.Definitions where +import Control.Applicative ((<$>)) import Control.Monad.State -import Data.Either (partitionEithers) +import Data.Bits (xor) +import Data.List (foldl') import qualified Data.Map as M import qualified Data.Set as S -import qualified Text.ParserCombinators.Parsec as P 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 Definitions +readDefinitions s = addDefinitionsHash s <$> d + where d = makeDefinitions (parseDefinitions s) + type DefineMonad = StateT Definitions (Either QuantityError) makeDefinitions :: [Definition] -> Either QuantityError Definitions makeDefinitions ds = execStateT (mapM addDefinition ds) emptyDefinitions @@ -47,9 +56,9 @@ if null defCheck then case pq of (Right pq') -> do - let (Quantity baseFac baseUnits _) = convertBase' d pq' + let (Quantity baseFac baseUnits) = convertBase' d pq' put $ d `unionDefinitions` emptyDefinitions { - bases = M.singleton sym (baseFac, baseUnits) + bases = M.singleton sym (baseFac, sUnits baseUnits) , synonyms = M.fromList $ zip (sym : syns) (repeat sym) , unitsList = sym : syns } (Left err) -> lift . Left $ err @@ -60,33 +69,13 @@ checkDefined :: [Symbol] -> [Symbol] -> [Symbol] checkDefined a b = S.toList $ S.intersection (S.fromList a) (S.fromList b) --- Convert prefixes and synonyms -preprocessQuantity :: Definitions -> Quantity -> Either QuantityError Quantity -preprocessQuantity d (Quantity x us _) - | null errs = Right $ Quantity x us' d - | otherwise = Left $ head errs - where ppUnits = map (preprocessUnit d) us - (errs, us') = partitionEithers ppUnits -preprocessUnit :: Definitions -> SimpleUnit -> Either QuantityError 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 - - -prefixParser :: Definitions -> String -> (String, String) -prefixParser d input = if input `elem` unitsList d - then ("", input) - else case P.parse (prefixParser' d) "arithmetic" input of - Left _ -> ("", input) - Right val -> splitAt (length val) input - +-- | Variant of the DJB2 hash; +hash :: String -> Int +hash = foldl' (\h c -> 33*h `xor` fromEnum c) 5381 -prefixParser' :: Definitions -> P.Parser String -prefixParser' d = do - pr <- P.choice $ map (P.try . P.string) (prefixes d) - _ <- P.choice $ map (P.try . P.string) (unitsList d) - return pr +-- | 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 --- a/library/Data/Quantities/ExprParser.hs +++ b/library/Data/Quantities/ExprParser.hs @@ -5,73 +5,157 @@ module Data.Quantities.ExprParser where import Control.Applicative ((<*>), (<$>), (*>), (<*)) +import Data.Either (partitionEithers) +import qualified Data.Map as M import Numeric (readFloat) -import System.Environment import Text.ParserCombinators.Parsec -import Data.Quantities.Data (SimpleUnit(..), Quantity(..), baseQuant, - multiplyQuants, divideQuants, exptQuants) - -main :: IO () -main = do - args <- getArgs - putStrLn $ readExpr (head args) - -readExpr :: String -> String -readExpr input = case parse parseExpr "arithmetic" input of - Left err -> "No match: " ++ show err - Right val -> show val +import Data.Quantities.Convert (addQuants, subtractQuants) +import Data.Quantities.Data spaces' :: Parser String spaces' = many $ char ' ' -parseExprQuant :: String -> Either String Quantity -parseExprQuant input = case parse parseExpr "arithmetic" input of - Left err -> Left $ "No match: " ++ show err - Right val -> Right val +parseExprQuant :: Definitions -> String -> Either QuantityError Quantity +parseExprQuant d input = case parse (parseExpr d) "arithmetic" input of + Left err -> Left $ ParserError $ show err + Right val -> val -- | Converts string to a Quantity using an expression grammar parser. -parseExpr :: Parser Quantity -parseExpr = spaces' >> parseExpr' <* spaces' - --- parseExpr', parseTerm, parseFactor, parseExp, parseNestedExpr :: Parser Quantity --- parseExpr' = try parseTermOp <|> parseTerm --- parseTerm = try parseFactorOp <|> parseFactor --- parseFactor = try parseExpOp <|> parseExp --- parseExp = try parseNestedExpr <|> parseSymbolNum --- parseNestedExpr = spaces' >> char '(' *> spaces' >> parseExpr' <* spaces' <* char ')' <* spaces' "parseNested" +type EQuant = Either QuantityError Quantity --- parseExpOp, parseTermOp, parseFactorOp :: Parser Quantity --- parseExpOp = parseExp `chainl1` expOp --- parseTermOp = parseTerm `chainl1` addOp --- parseFactorOp = parseFactor `chainl1` mulOp +parseExpr :: Definitions -> Parser EQuant +parseExpr d = spaces' >> parseExpr' d <* spaces' -parseExpr', parseFactor, parseExp, parseNestedExpr :: Parser Quantity -parseExpr' = try parseFactorOp <|> parseFactor -parseFactor = try parseExpOp <|> parseExp -parseExp = try parseNestedExpr <|> parseSymbolNum -parseNestedExpr = spaces' >> char '(' *> spaces' >> parseExpr' <* spaces' <* char ')' <* spaces' "parseNested" +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" -parseExpOp, parseFactorOp :: Parser Quantity -parseExpOp = parseExp `chainl1` expOp -parseFactorOp = parseFactor `chainl1` mulOp +parseExptOp, parseTermOp, parseFactorOp :: Definitions -> Parser EQuant +parseExptOp d = parseExpt d `chainl1` exptOp +parseTermOp d = parseTerm d `chainl1` addOp +parseFactorOp d = parseFactor d `chainl1` mulOp -expOp, mulOp :: Parser (Quantity -> Quantity -> Quantity) --- addOp = try parseAdd <|> parseSubtract "addOp" --- where parseAdd = char '+' >> spaces' >> return (addQuants) --- parseSubtract = char '-' >> spaces' >> return (subtractQuants) +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 = char '/' >> spaces' >> return divideEQuants + parseImplicitTimes = return multiplyEQuants +exptOp = try (opChoice >> spaces' >> return exptEQuants) "expOp" + where opChoice = string "^" <|> string "**" + + +addEQuants :: EQuant -> EQuant -> EQuant +addEQuants (Right a) (Right b) = addQuants a b +addEQuants (Left a) _ = Left a +addEQuants _ (Left b) = Left b + +subtractEQuants :: EQuant -> EQuant -> EQuant +subtractEQuants (Right a) (Right b) = subtractQuants a b +subtractEQuants (Left a) _ = Left a +subtractEQuants _ (Left b) = Left b + +multiplyEQuants :: EQuant -> EQuant -> EQuant +multiplyEQuants (Right a) (Right b) = Right $ multiplyQuants a b +multiplyEQuants (Left a) _ = Left a +multiplyEQuants _ (Left b) = Left b + +divideEQuants :: EQuant -> EQuant -> EQuant +divideEQuants (Right a) (Right b) = Right $ divideQuants a b +divideEQuants (Left a) _ = Left a +divideEQuants _ (Left b) = Left b + +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, ")"] + +parseESymbolNum :: Definitions -> Parser EQuant +parseESymbolNum d = try (parseENum d) <|> parseESymbol d + +parseESymbol :: Definitions -> Parser EQuant +parseESymbol d = do + q <- parseSymbol' + return $ preprocessQuantity d q + +parseENum :: Definitions -> Parser EQuant +parseENum d = do + q <- parseNum + return $ Right $ q { units = (units q) { defs = d } } + +-- | Convert prefixes and synonyms +preprocessQuantity :: Definitions -> Quantity -> Either QuantityError Quantity +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 + +preprocessUnit :: Definitions -> SimpleUnit -> Either QuantityError 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 + + +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 + + +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 +parseMultExpr = spaces' >> parseMultExpr' <* spaces' + +parseMultExpr', parseMultFactor, parseMultExpt, parseMultNestedExpr :: Parser Quantity +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 +parseMultExptOp = parseMultExpt `chainl1` exptMultOp +parseMultFactorOp = parseMultFactor `chainl1` mulMultOp + +exptMultOp, mulMultOp :: Parser (Quantity -> Quantity -> Quantity) +mulMultOp = try parseTimes <|> try parseDiv <|> parseImplicitTimes "mulMultOp" where parseTimes = char '*' >> spaces' >> return multiplyQuants parseDiv = char '/' >> spaces' >> return divideQuants parseImplicitTimes = return multiplyQuants -expOp = try (opChoice >> spaces' >> return exptQuants') "expOp" +exptMultOp = try (opChoice >> spaces' >> return exptMultQuants') "expMultOp" where opChoice = string "^" <|> string "**" - -exptQuants' :: Quantity -> Quantity -> Quantity -exptQuants' q (Quantity y [] _) = exptQuants q y -exptQuants' a b = error $ "Used non-dimensionless exponent in " ++ showq +exptMultQuants' :: Quantity -> Quantity -> Quantity +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, ")"] parseSymbolNum :: Parser Quantity diff --git a/quantities.cabal b/quantities.cabal --- a/quantities.cabal +++ b/quantities.cabal @@ -1,5 +1,5 @@ name: quantities -version: 0.1.0 +version: 0.2.0 author: John David Reaver maintainer: John David Reaver build-type: Simple @@ -28,14 +28,13 @@ library default-language: Haskell2010 exposed-modules: Data.Quantities - , Data.Quantities.DefaultUnits hs-source-dirs: library ghc-options: -Wall build-depends: base >=4 && < 5, containers, mtl, parsec other-modules: Data.Quantities.Convert , Data.Quantities.Constructors , Data.Quantities.Data - + , Data.Quantities.DefaultUnits , Data.Quantities.Definitions , Data.Quantities.DefinitionParser , Data.Quantities.ExprParser