quantities 0.1.0 → 0.2.0
raw patch · 10 files changed
+339/−184 lines, 10 files
Files
- CHANGES.md +9/−1
- library/Data/Quantities.hs +43/−11
- library/Data/Quantities/Constructors.hs +26/−16
- library/Data/Quantities/Convert.hs +28/−23
- library/Data/Quantities/Data.hs +68/−33
- library/Data/Quantities/DefaultUnits.hs +1/−1
- library/Data/Quantities/DefinitionParser.hs +10/−17
- library/Data/Quantities/Definitions.hs +21/−32
- library/Data/Quantities/ExprParser.hs +131/−47
- quantities.cabal +2/−3
CHANGES.md view
@@ -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
library/Data/Quantities.hs view
@@ -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)
library/Data/Quantities/Constructors.hs view
@@ -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
library/Data/Quantities/Convert.hs view
@@ -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
library/Data/Quantities/Data.hs view
@@ -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 }
library/Data/Quantities/DefaultUnits.hs view
@@ -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
library/Data/Quantities/DefinitionParser.hs view
@@ -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"
library/Data/Quantities/Definitions.hs view
@@ -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; <http://stackoverflow.com/a/9263004/1333514>+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 }
library/Data/Quantities/ExprParser.hs view
@@ -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
quantities.cabal view
@@ -1,5 +1,5 @@ name: quantities-version: 0.1.0+version: 0.2.0 author: John David Reaver <jdreaver@adlerhorst.com> maintainer: John David Reaver <jdreaver@adlerhorst.com> 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