diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2014, Richard Eisenberg and Adam Gundry +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 author 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/Tests/Parser.hs b/Tests/Parser.hs new file mode 100644 --- /dev/null +++ b/Tests/Parser.hs @@ -0,0 +1,283 @@ +{- Test the unit parser + Copyright (c) 2014 Richard Eisenberg +-} + +{-# LANGUAGE TemplateHaskell, TypeOperators #-} + +module Tests.Parser where + +import Prelude hiding ( lex, exp ) + +import Text.Parse.Units + +import Control.Monad.Reader +import qualified Data.Map.Strict as Map +import Text.Parsec +import Data.Generics +import Language.Haskell.TH + +import Test.Tasty +import Test.Tasty.HUnit + +leftOnly :: Either a b -> Maybe a +leftOnly (Left a) = Just a +leftOnly (Right _) = Nothing + +---------------------------------------------------------------------- +-- TH functions +---------------------------------------------------------------------- + +stripModules :: Data a => a -> a +stripModules = everywhere (mkT (mkName . nameBase)) + +pprintUnqualified :: (Ppr a, Data a) => a -> String +pprintUnqualified = pprint . stripModules + +---------------------------------------------------------------------- +-- Lexer +---------------------------------------------------------------------- + +lexTest :: String -> String +lexTest s = + case lex s of + Left _ -> "error" + Right toks -> show toks + +lexTestCases :: [(String, String)] +lexTestCases = [ ( "m", "[m]" ) + , ( "", "[]" ) + , ( "m s", "[m,s]" ) + , ( " m s ", "[m,s]" ) + , ( "m ", "[m]" ) + , ( " m", "[m]" ) + , ( "( m /s", "[(,m,/,s]" ) + , ( "!", "error" ) + , ( "1 2 3", "[1,2,3]" ) + , ( " ", "[]" ) + ] + +lexTests :: TestTree +lexTests = testGroup "Lexer" $ + map (\(str, out) -> testCase ("`" ++ str ++ "'") $ lexTest str @?= out) lexTestCases + +---------------------------------------------------------------------- +-- Unit strings +---------------------------------------------------------------------- + +unitStringTestCases :: [(String, String)] +unitStringTestCases = [ ("m", "Meter") + , ("s", "Second") + , ("min", "Minute") + , ("km", "Kilo :@ Meter") + , ("mm", "Milli :@ Meter") + , ("kmin", "Kilo :@ Minute") + , ("dam", "error") -- ambiguous! + , ("damin", "Deca :@ Minute") + , ("ms", "Milli :@ Second") + , ("mmin", "Milli :@ Minute") + , ("mmm", "error") + , ("mmmin", "error") + , ("sm", "error") + , ("", "error") + , ("dak", "error") + , ("das", "Deca :@ Second") + , ("ds", "Deci :@ Second") + , ("daam", "Deca :@ Ampere") + , ("kam", "Kilo :@ Ampere") + , ("dm", "Deci :@ Meter") + ] + +parseUnitStringTest :: String -> String +parseUnitStringTest s = + case flip runReader testSymbolTable $ runParserT unitStringParser () "" s of + Left _ -> "error" + Right exp -> show exp + +unitStringTests :: TestTree +unitStringTests = testGroup "UnitStrings" $ + map (\(str, out) -> testCase ("`" ++ str ++ "'") $ parseUnitStringTest str @?= out) + unitStringTestCases + +---------------------------------------------------------------------- +-- Symbol tables +---------------------------------------------------------------------- + +mkSymbolTableTests :: TestTree +mkSymbolTableTests = testGroup "mkSymbolTable" + [ testCase "Unambiguous1" (Map.keys (prefixTable testSymbolTable) @?= ["d","da","k","m"]) + -- , testCase "Unambiguous2" (Map.keys (unitTable testSymbolTable) @?= ["am","m","min","s"]) + , testCase "AmbigPrefix" (leftOnly (mkSymbolTable [("a",''Milli),("a",''Centi)] ([] :: [(String,Name)])) @?= Just "The label `a' is assigned to the following meanings:\n[\"Tests.Parser.Milli\",\"Tests.Parser.Centi\"]\nThis is ambiguous. Please fix before building a unit parser.") + , testCase "AmbigUnit" (leftOnly (mkSymbolTable ([] :: [(String,Name)]) [("m",''Meter),("m",''Minute)]) @?= Just "The label `m' is assigned to the following meanings:\n[\"Tests.Parser.Meter\",\"Tests.Parser.Minute\"]\nThis is ambiguous. Please fix before building a unit parser.") + , testCase "MultiAmbig" (leftOnly (mkSymbolTable [("a",''Milli),("b",''Centi),("b",''Deci),("b",''Kilo),("c",''Atto),("c",''Deca)] [("m",''Meter),("m",''Minute),("s",''Second)]) @?= Just "The label `b' is assigned to the following meanings:\n[\"Tests.Parser.Centi\",\"Tests.Parser.Deci\",\"Tests.Parser.Kilo\"]\nThe label `c' is assigned to the following meanings:\n[\"Tests.Parser.Atto\",\"Tests.Parser.Deca\"]\nThis is ambiguous. Please fix before building a unit parser.") + ] + +testSymbolTable :: SymbolTable Name Name +Right testSymbolTable = + mkSymbolTable (stripModules [ ("k", ''Kilo) + , ("da", ''Deca) + , ("m", ''Milli) + , ("d", ''Deci) ]) + (stripModules [ ("m", ''Meter) + , ("s", ''Second) + , ("min", ''Minute) + , ("am", ''Ampere) ]) + +data Kilo = Kilo +data Deca = Deca +data Centi = Centi +data Milli = Milli +data Deci = Deci +data Atto = Atto + +data Meter = Meter +data Second = Second +data Minute = Minute +data Ampere = Ampere + +---------------------------------------------------------------------- +-- TH conversions, taken from the `units` package +---------------------------------------------------------------------- + +-- This is silly, but better than rewriting the tests. +-- Note that we can't depend on `units` package, because we want +-- `units` to depend on `units-parser`. Urgh. +data Number = Number +data a :@ b = a :@ b +data a :* b = a :* b +data a :/ b = a :/ b +data a :^ b = a :^ b + +data Succ a +data Z = Zero + +sPred, sSucc, sZero :: () +sPred = () +sSucc = () +sZero = () + +parseUnitExp :: SymbolTable Name Name -> String -> Either String Exp +parseUnitExp tbl s = to_exp `liftM` parseUnit tbl s -- the Either monad + where + to_exp Unity = ConE 'Number + to_exp (Unit (Just pre) unit) = ConE '(:@) `AppE` of_type pre `AppE` of_type unit + to_exp (Unit Nothing unit) = of_type unit + to_exp (Mult e1 e2) = ConE '(:*) `AppE` to_exp e1 `AppE` to_exp e2 + to_exp (Div e1 e2) = ConE '(:/) `AppE` to_exp e1 `AppE` to_exp e2 + to_exp (Pow e i) = ConE '(:^) `AppE` to_exp e `AppE` mk_sing i + + of_type :: Name -> Exp + of_type n = (VarE 'undefined) `SigE` (ConT n) + + mk_sing :: Integer -> Exp + mk_sing n + | n < 0 = VarE 'sPred `AppE` mk_sing (n + 1) + | n > 0 = VarE 'sSucc `AppE` mk_sing (n - 1) + | otherwise = VarE 'sZero + +parseUnitType :: SymbolTable Name Name -> String -> Either String Type +parseUnitType tbl s = to_type `liftM` parseUnit tbl s -- the Either monad + where + to_type Unity = ConT ''Number + to_type (Unit (Just pre) unit) = ConT ''(:@) `AppT` ConT pre `AppT` ConT unit + to_type (Unit Nothing unit) = ConT unit + to_type (Mult e1 e2) = ConT ''(:*) `AppT` to_type e1 `AppT` to_type e2 + to_type (Div e1 e2) = ConT ''(:/) `AppT` to_type e1 `AppT` to_type e2 + to_type (Pow e i) = ConT ''(:^) `AppT` to_type e `AppT` mk_z i + + mk_z :: Integer -> Type + mk_z n + | n < 0 = ConT ''Pred `AppT` mk_z (n + 1) + | n > 0 = ConT ''Succ `AppT` mk_z (n - 1) + | otherwise = ConT 'Zero -- single quote as it's a data constructor! + +---------------------------------------------------------------------- +-- Overall parser +---------------------------------------------------------------------- + +parseUnitTest :: String -> String +parseUnitTest s = + case parseUnitExp testSymbolTable s of + Left _ -> "error" + Right exp -> pprintUnqualified exp + +parseTestCases :: [(String, String)] +parseTestCases = + [ ("m", "undefined :: Meter") + , ("s", "undefined :: Second") + , ("ms", "(:@) (undefined :: Milli) (undefined :: Second)") + , ("mm", "(:@) (undefined :: Milli) (undefined :: Meter)") + , ("mmm", "error") + , ("km", "(:@) (undefined :: Kilo) (undefined :: Meter)") + , ("m s", "(:*) (undefined :: Meter) (undefined :: Second)") + , ("m/s", "(:/) (undefined :: Meter) (undefined :: Second)") + , ("m/s^2", "(:/) (undefined :: Meter) ((:^) (undefined :: Second) (sSucc (sSucc sZero)))") + , ("s/m m", "(:/) (undefined :: Second) ((:*) (undefined :: Meter) (undefined :: Meter))") + , ("s s/m m", "(:/) ((:*) (undefined :: Second) (undefined :: Second)) ((:*) (undefined :: Meter) (undefined :: Meter))") + , ("s*s/m*m", "(:*) ((:/) ((:*) (undefined :: Second) (undefined :: Second)) (undefined :: Meter)) (undefined :: Meter)") + , ("s*s/(m*m)", "(:/) ((:*) (undefined :: Second) (undefined :: Second)) ((:*) (undefined :: Meter) (undefined :: Meter))") + , ("m^-1", "(:^) (undefined :: Meter) (sPred sZero)") + , ("m^(-1)", "(:^) (undefined :: Meter) (sPred sZero)") + , ("m^(-(1))", "(:^) (undefined :: Meter) (sPred sZero)") + , ("1", "Number") + , ("1/s", "(:/) Number (undefined :: Second)") + , ("m 1 m", "(:*) ((:*) (undefined :: Meter) Number) (undefined :: Meter)") + , (" ", "Number") + , ("", "Number") + ] + +parseUnitTests :: TestTree +parseUnitTests = testGroup "ParseUnit" $ + map (\(str, out) -> testCase ("`" ++ str ++ "'") $ parseUnitTest str @?= out) + parseTestCases + +parseUnitTestT :: String -> String +parseUnitTestT s = + case parseUnitType testSymbolTable s of + Left _ -> "error" + Right exp -> pprintUnqualified exp + +parseTestCasesT :: [(String, String)] +parseTestCasesT = + [ ("m", "Meter") + , ("s", "Second") + , ("ms", ":@ Milli Second") + , ("mm", ":@ Milli Meter") + , ("mmm", "error") + , ("km", ":@ Kilo Meter") + , ("m s", ":* Meter Second") + , ("m/s", ":/ Meter Second") + , ("m/s^2", ":/ Meter (:^ Second (Succ (Succ Zero)))") + , ("s/m m", ":/ Second (:* Meter Meter)") + , ("s s/m m", ":/ (:* Second Second) (:* Meter Meter)") + , ("s*s/m*m", ":* (:/ (:* Second Second) Meter) Meter") + , ("s*s/(m*m)", ":/ (:* Second Second) (:* Meter Meter)") + , ("m^-1", ":^ Meter (Pred Zero)") + , ("m^(-1)", ":^ Meter (Pred Zero)") + , ("m^(-(1))", ":^ Meter (Pred Zero)") + , ("1", "Number") + , ("1/s", ":/ Number Second") + , ("m 1 m", ":* (:* Meter Number) Meter") + , (" ", "Number") + , ("", "Number") + ] + +parseUnitTestsT :: TestTree +parseUnitTestsT = testGroup "ParseUnitType" $ + map (\(str, out) -> testCase ("`" ++ str ++ "'") $ parseUnitTestT str @?= out) + parseTestCasesT + +---------------------------------------------------------------------- +-- Conclusion +---------------------------------------------------------------------- + +tests :: TestTree +tests = testGroup "Parser" + [ lexTests + , mkSymbolTableTests + , unitStringTests + , parseUnitTests + , parseUnitTestsT + ] + +main :: IO () +main = defaultMain tests diff --git a/Text/Parse/Units.hs b/Text/Parse/Units.hs new file mode 100644 --- /dev/null +++ b/Text/Parse/Units.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE LambdaCase, NoMonomorphismRestriction, FlexibleContexts, RankNTypes, + Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parse.Units +-- Copyright : (C) 2014 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines a parser for unit expressions. The syntax for +-- these expressions is like F#'s. There are four arithmetic operators +-- (@*@, @/@, @^@, and juxtaposition). Exponentiation binds the +-- tightest, and it allows an integer to its right (possibly with +-- minus signs and parentheses). Next tightest is juxtaposition, which +-- indicates multiplication. Because juxtaposition binds tighter than +-- division, the expressions @m/s^2@ and @m/s s@ are +-- equivalent. Multiplication and division bind the loosest and are +-- left-associative, meaning that @m/s*s@ is equivalent to @(m/s)*s@, +-- probably not what you meant. Parentheses in unit expressions are +-- allowed, of course. +-- +-- Within a unit string (that is, a unit with an optional prefix), +-- there may be ambiguity. If a unit string can be interpreted as a +-- unit without a prefix, that parsing is preferred. Thus, @min@ would +-- be minutes, not milli-inches (assuming appropriate prefixes and +-- units available.) There still may be ambiguity between unit +-- strings, even interpreting the string as a prefix and a base +-- unit. If a unit string is amiguous in this way, it is rejected. +-- For example, if we have prefixes @da@ and @d@ and units @m@ and +-- @am@, then @dam@ is ambiguous like this. +----------------------------------------------------------------------------- + +module Text.Parse.Units ( + -- * Parsing units + UnitExp(..), parseUnit, + + -- * Symbol tables + SymbolTable(..), PrefixTable, UnitTable, mkSymbolTable, + unsafeMkSymbolTable, universalSymbolTable, + + -- * Testing only + lex, unitStringParser + ) where + +import Prelude hiding ( lex, div ) + +import Text.Parsec hiding ( tab ) +import Text.Parsec.String +import Text.Parsec.Pos +import qualified Data.Map.Strict as Map +import qualified Data.MultiMap as MM +import Control.Monad.Reader +import Control.Arrow hiding ( app) +import Data.Maybe +import Data.Char + +---------------------------------------------------------------------- +-- Basic combinators +---------------------------------------------------------------------- + +-- copied from GHC +partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) +partitionWith _ [] = ([],[]) +partitionWith f (x:xs) = case f x of + Left b -> (b:bs, cs) + Right c -> (bs, c:cs) + where (bs,cs) = partitionWith f xs + +---------------------------------------------------------------------- +-- Extra parser combinators +---------------------------------------------------------------------- + +-- | @experiment p@ runs @p@. If @p@ succeeds, @experiment@ returns the +-- result of running @p@. If @p@ fails, then @experiment@ returns @Nothing@. +-- In either case, no input is consumed and @experiment@ never fails. +experiment :: Stream s m t => ParsecT s u m a -> ParsecT s u m (Maybe a) +experiment = lookAhead . optionMaybe . try + +consumeAll :: (Stream s m t, Show t) => ParsecT s u m a -> ParsecT s u m a +consumeAll p = do + result <- p + eof + return result + +nochar :: Stream s m Char => Char -> ParsecT s u m () +nochar = void . char + +---------------------------------------------------------------------- +-- Datatypes +---------------------------------------------------------------------- + +data Op = NegO | MultO | DivO | PowO | OpenP | CloseP + +instance Show Op where + show NegO = "-" + show MultO = "*" + show DivO = "/" + show PowO = "^" + show OpenP = "(" + show CloseP = ")" + +data Token = UnitT String + | NumberT Integer + | OpT Op + +instance Show Token where + show (UnitT s) = s + show (NumberT i) = show i + show (OpT op) = show op + +-- | Parsed unit expressions, parameterized by a prefix identifier type and +-- a unit identifier type +data UnitExp pre u = Unity -- ^ "1" + | Unit (Maybe pre) u -- ^ a unit with, perhaps, a prefix + | Mult (UnitExp pre u) (UnitExp pre u) + | Div (UnitExp pre u) (UnitExp pre u) + | Pow (UnitExp pre u) Integer + +instance (Show pre, Show u) => Show (UnitExp pre u) where + show Unity = "1" + show (Unit (Just pre) u) = show pre ++ " :@ " ++ show u + show (Unit Nothing u) = show u + show (Mult e1 e2) = "(" ++ show e1 ++ " :* " ++ show e2 ++ ")" + show (Div e1 e2) = "(" ++ show e1 ++ " :/ " ++ show e2 ++ ")" + show (Pow e i) = show e ++ " :^ " ++ show i + +---------------------------------------------------------------------- +-- Lexer +---------------------------------------------------------------------- + +type Lexer = Parser + +unitL :: Lexer Token +unitL = UnitT `fmap` (many1 letter) + +opL :: Lexer Token +opL = fmap OpT $ + do { nochar '-'; return NegO } + <|> do { nochar '*'; return MultO } + <|> do { nochar '/'; return DivO } + <|> do { nochar '^'; return PowO } + <|> do { nochar '('; return OpenP } + <|> do { nochar ')'; return CloseP } + +numberL :: Lexer Token +numberL = (NumberT . read) `fmap` (many1 digit) + +lexer1 :: Lexer Token +lexer1 = unitL <|> opL <|> numberL + +lexer :: Lexer [Token] +lexer = do + spaces + choice + [ do eof "" + return [] + , do tok <- lexer1 + spaces + toks <- lexer + return (tok : toks) + ] + +lex :: String -> Either ParseError [Token] +lex = parse lexer "" + +---------------------------------------------------------------------- +-- Symbol tables +---------------------------------------------------------------------- + +-- | A finite mapping from prefix spellings to prefix identifiers (of +-- unspecified type @pre@). All prefix spellings must be strictly alphabetic. +type PrefixTable pre = Map.Map String pre + +-- | A mapping from unit spellings to unit identifiers (of unspecified type +-- @u@). All unit spellings must be strictly alphabetic. +type UnitTable u = String -> Maybe u + +-- | A "symbol table" for the parser, mapping prefixes and units to their +-- representations. +data SymbolTable pre u = SymbolTable { prefixTable :: PrefixTable pre + , unitTable :: UnitTable u + } + +-- | Build a 'Map' from an association list, checking for ambiguity +unambFromList :: (Ord a, Show b) => [(a,b)] -> Either [(a,[String])] (Map.Map a b) +unambFromList list = + let multimap = MM.fromList list + assocs = MM.assocs multimap + (errs, goods) = partitionWith (\(key, vals) -> + case vals of + [val] -> Right (key, val) + _ -> Left (key, map show vals)) assocs + result = Map.fromList goods + in + if null errs then Right result else Left errs + +-- | Build a symbol table from prefix mappings and unit mappings. The prefix mapping +-- can be empty. This function checks to make sure that the strings are not +-- inherently ambiguous and are purely alphabetic. +mkSymbolTable :: (Show pre, Show u) + => [(String, pre)] -- ^ Association list of prefixes + -> [(String, u)] -- ^ Association list of units + -> Either String (SymbolTable pre u) +mkSymbolTable prefixes units = + let bad_strings = filter (not . all isLetter) (map fst prefixes ++ map fst units) in + if not (null bad_strings) + then Left $ "All prefixes and units must be composed entirely of letters.\nThe following are illegal: " ++ show bad_strings + else + let result = do + prefixTab <- unambFromList prefixes + unitTab <- unambFromList units + return $ SymbolTable { prefixTable = prefixTab, unitTable = flip Map.lookup unitTab } + in left ((++ error_suffix) . concatMap mk_error_string) result + where + mk_error_string :: Show x => (String, [x]) -> String + mk_error_string (k, vs) = + "The label `" ++ k ++ "' is assigned to the following meanings:\n" ++ + show vs ++ "\n" + error_suffix = "This is ambiguous. Please fix before building a unit parser." + +-- | Make a symbol table without checking for ambiguity or non-purely +-- alphabetic strings. The prefixes must be a (potentially empty) +-- finite map, but the units mapping need not be finite. +-- Note that this is unsafe in that the resulting parser may behave +-- unpredictably. It surely won't launch the rockets, though. +unsafeMkSymbolTable :: PrefixTable pre -> UnitTable u -> SymbolTable pre u +unsafeMkSymbolTable = SymbolTable + +-- | A symbol table that accepts all unit strings, but supports no prefixes. +universalSymbolTable :: SymbolTable a String +universalSymbolTable = SymbolTable Map.empty Just + + +---------------------------------------------------------------------- +-- Unit string parser +---------------------------------------------------------------------- + +-- We assume that no symbol table is inherently ambiguous! + +type GenUnitStringParser pre u = ParsecT String () (Reader (SymbolTable pre u)) +type UnitStringParser_UnitExp = + forall pre u. (Show pre, Show u) => GenUnitStringParser pre u (UnitExp pre u) + +-- parses just a unit (no prefix) +justUnitP :: GenUnitStringParser pre u u +justUnitP = do + full_string <- getInput + units <- asks unitTable + case units full_string of + Nothing -> fail (full_string ++ " does not match any known unit") + Just u -> return u + +-- parses a unit and prefix, failing in the case of ambiguity +prefixUnitP :: UnitStringParser_UnitExp +prefixUnitP = do + prefixTab <- asks prefixTable + let assocs = Map.assocs prefixTab -- these are in the right order + results <- catMaybes `liftM` mapM (experiment . parse_one) assocs + full_string <- getInput + case results of + [] -> fail $ "No known interpretation for " ++ full_string + [(pre_name, unit_name)] -> + return $ Unit (Just pre_name) unit_name + lots -> fail $ "Multiple possible interpretations for " ++ full_string ++ ":\n" ++ + (concatMap (\(pre_name, unit_name) -> + " " ++ show pre_name ++ + " :@ " ++ show unit_name ++ "\n") lots) + where + parse_one :: (String, pre) -> GenUnitStringParser pre u (pre, u) + parse_one (pre, name) = do + void $ string pre + unit_name <- justUnitP + return (name, unit_name) + +-- parse a unit string +unitStringParser :: UnitStringParser_UnitExp +unitStringParser = try (Unit Nothing `liftM` justUnitP) <|> prefixUnitP + +---------------------------------------------------------------------- +-- Unit expression parser +---------------------------------------------------------------------- + +type GenUnitParser pre u = ParsecT [Token] () (Reader (SymbolTable pre u)) +type UnitParser a = forall pre u. GenUnitParser pre u a +type UnitParser_UnitExp = + forall pre u. (Show pre, Show u) => GenUnitParser pre u (UnitExp pre u) + +-- move a source position past a token +updatePosToken :: SourcePos -> Token -> [Token] -> SourcePos +updatePosToken pos (UnitT unit_str) _ = updatePosString pos unit_str +updatePosToken pos (NumberT i) _ = updatePosString pos (show i) +updatePosToken pos (OpT _) _ = incSourceColumn pos 1 + +-- parse a Token +uToken :: (Token -> Maybe a) -> UnitParser a +uToken = tokenPrim show updatePosToken + +-- consume an lparen +lparenP :: UnitParser () +lparenP = uToken $ \case + OpT OpenP -> Just () + _ -> Nothing + +-- consume an rparen +rparenP :: UnitParser () +rparenP = uToken $ \case + OpT CloseP -> Just () + _ -> Nothing + +-- parse a unit string +unitStringP :: String -> UnitParser_UnitExp +unitStringP str = do + symbolTable <- ask + case flip runReader symbolTable $ runParserT unitStringParser () "" str of + Left err -> fail (show err) + Right e -> return e + +-- parse a number, possibly negated and nested in parens +numP :: UnitParser Integer +numP = + do lparenP + n <- numP + rparenP + return n + <|> + do uToken $ \case + OpT NegO -> Just () + _ -> Nothing + negate `liftM` numP + <|> + do uToken $ \case + NumberT i -> Just i + _ -> Nothing + +-- parse an exponentiation, like "^2" +powP :: GenUnitParser pre u (UnitExp pre u -> UnitExp pre u) +powP = option id $ do + uToken $ \case + OpT PowO -> Just () + _ -> Nothing + n <- numP + return $ flip Pow n + +-- parse a unit, possibly with an exponent +unitP :: UnitParser_UnitExp +unitP = + do n <- numP + case n of + 1 -> return Unity + _ -> unexpected $ "number " ++ show n + <|> + do unit_str <- uToken $ \case + UnitT unit_str -> Just unit_str + _ -> Nothing + u <- unitStringP unit_str + maybe_pow <- powP + return $ maybe_pow u + +-- parse a "unit factor": either a juxtaposed sequence of units +-- or a paranthesized unit exp. +unitFactorP :: UnitParser_UnitExp +unitFactorP = + do lparenP + unitExp <- parser + rparenP + return unitExp + <|> + (foldl1 Mult `liftM` many1 unitP) + +-- parse * or / +opP :: GenUnitParser pre u (UnitExp pre u -> UnitExp pre u -> UnitExp pre u) +opP = uToken $ \case + OpT MultO -> Just Mult + OpT DivO -> Just Div + _ -> Nothing + +-- parse a whole unit expression +parser :: UnitParser_UnitExp +parser = chainl unitFactorP opP Unity + +-- | Parse a unit expression, interpreted with respect the given symbol table. +-- Returns either an error message or the successfully-parsed unit expression. +parseUnit :: (Show pre, Show u) + => SymbolTable pre u -> String -> Either String (UnitExp pre u) +parseUnit tab s = left show $ do + toks <- lex s + flip runReader tab $ runParserT (consumeAll parser) () "" toks diff --git a/units-parser.cabal b/units-parser.cabal new file mode 100644 --- /dev/null +++ b/units-parser.cabal @@ -0,0 +1,49 @@ +name: units-parser +version: 0.1.0.0 +cabal-version: >= 1.10 +synopsis: A parser for units of measure +category: Text +author: Richard Eisenberg +maintainer: Richard Eisenberg , Adam Gundry +bug-reports: https://github.com/adamgundry/units-parser/issues +stability: experimental +license: BSD3 +license-file: LICENSE +build-type: Simple +description: + + The @units-parser@ package provides a parser for unit expressions + with F#-style syntax, to support the @units@ package and other + packages providing type-level units of measure. + +source-repository head + type: git + location: https://github.com/adamgundry/units-parser.git + +library + ghc-options: -Wall + build-depends: base >= 4.7 && < 5 + , mtl >= 1.1 + , multimap >= 1.2 + , containers >= 0.4 + , parsec >= 3 + exposed-modules: + Text.Parse.Units + + default-language: Haskell2010 + +test-suite main + type: exitcode-stdio-1.0 + main-is: Tests/Parser.hs + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , tasty >= 0.8 + , tasty-hunit >= 0.8 + , template-haskell + , mtl >= 1.1 + , multimap >= 1.2 + , syb >= 0.3 + , containers >= 0.4 + , parsec >= 3 + + ghc-options: -O0 -Wall -Werror -main-is Tests.Parser