diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog + +`flexible-numeric-parsers` uses [PVP Versioning][1]. +The changelog is available [on GitHub][2]. + +## 0.0.0.0 + +* Initially created. + +[1]: https://pvp.haskell.org +[2]: https://github.com/patrickt/flexible-numeric-parsers/releases diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2020 Patrick Thomson + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# flexible-numeric-parsers + +[![GitHub CI](https://github.com/patrickt/flexible-numeric-parsers/workflows/CI/badge.svg)](https://github.com/patrickt/flexible-numeric-parsers/actions) +[![Hackage](https://img.shields.io/hackage/v/flexible-numeric-parsers.svg?logo=haskell)](https://hackage.haskell.org/package/flexible-numeric-parsers) +[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE) + +Flexible numeric parsers for real-world programming languages. These parsers accept values such as `100_000_000`, `0B1_1`, and `0xa_bcd_ef0`. + +This code was extracted from the [Semantic](http://github.com/github/semantic/) project. + +Currently missing support for complex numbers, suffixes indicating signedness/size (`U` and `L` and friends), and hexadecimal floats. If you need the former, file an issue; if you need the latter, then I sure want to know what your use case is. diff --git a/flexible-numeric-parsers.cabal b/flexible-numeric-parsers.cabal new file mode 100644 --- /dev/null +++ b/flexible-numeric-parsers.cabal @@ -0,0 +1,66 @@ +cabal-version: 2.4 +name: flexible-numeric-parsers +version: 0.1.0.0 +synopsis: Flexible numeric parsers for real-world programming languages. +description: This package provides parsers for integer, natural, and arbitrary-precision decimal + numbers that are compatible with the syntaxes of a wide variety of programming languages. +homepage: https://github.com/patrickt/flexible-numeric-parsers +bug-reports: https://github.com/patrickt/flexible-numeric-parsers/issues +license: MIT +license-file: LICENSE +author: Patrick Thomson +maintainer: Patrick Thomson +copyright: 2020 Patrick Thomson +category: Parsing +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md +tested-with: GHC == 8.8.3 + +source-repository head + type: git + location: https://github.com/patrickt/flexible-numeric-parsers.git + +common common-options + build-depends: base >= 4.12.0.0 && <5 + , parsers ^>= 0.12.10 + , scientific ^>= 0.3.6 + + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + if impl(ghc >= 8.0) + ghc-options: -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + -Wpartial-fields + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + + default-language: Haskell2010 + +library + import: common-options + hs-source-dirs: src + exposed-modules: Numeric.Parse.Flexible + +test-suite flexible-numeric-parsers-test + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Generators + build-depends: flexible-numeric-parsers + , hedgehog + , attoparsec + , text + , tasty + , tasty-hedgehog + , tasty-hunit + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N diff --git a/src/Numeric/Parse/Flexible.hs b/src/Numeric/Parse/Flexible.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Parse/Flexible.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +-- | Flexible numeric parsers for real-world programming languages. +-- These parsers aim to be a superset of the numeric syntaxes across +-- the most popular programming languages. +-- +-- All parsers assume any trailing whitespace has already been +-- consumed, and places no requirement for an @endOfInput@ at the end +-- of a literal. Be sure to handle these in a calling context. These +-- parsers do not use 'Text.Parser.Token.TokenParsing', and therefore +-- may fail while consuming input, depending on if you use a parser +-- that automatically backtracks or not. Apply 'try' if needed. +module Numeric.Parse.Flexible + ( integer, + natural, + decimal, + hexadecimal, + octal, + binary, + floating, + signed, + imaginary, + ) +where + +import Control.Applicative +import Control.Monad hiding (fail) +import Data.Scientific hiding (scientific) +import Numeric +import Text.Parser.Char +import Text.Parser.Combinators +import Text.Read (readMaybe) +import Prelude hiding (exponent, fail, takeWhile) +import Data.Complex +import Numeric.Natural (Natural) + +-- | Parse an integer in 'decimal', 'hexadecimal', 'octal', or 'binary', with optional leading sign. +-- +-- Note that because the 'octal' parser takes primacy over 'decimal', numbers with a leading +-- @0@ will be parsed as octal. This is unfortunate, but matches the behavior +-- of C, Python, and Ruby. +integer :: (CharParsing m, Monad m) => m Integer +integer = signed (choice [try hexadecimal, try octal, try binary, decimal]) + +-- | Parse a natural number in 'decimal', 'hexadecimal', 'octal', or 'binary'. As with 'integer', +-- a leading @0@ is interpreted as octal. Leading signs are not accepted. +natural :: (CharParsing m, Monad m) => m Natural +natural = fromIntegral <$> choice [try hexadecimal, try octal, try binary, decimal] + +-- | Parse an integer in base 10. +-- +-- Accepts @0..9@ and underscore separators. No leading signs are accepted. +decimal :: (CharParsing m, Monad m) => m Integer +decimal = do + contents <- withUnder digit + attempt contents + +-- | Parse a number in hexadecimal. +-- +-- Requires a @0x@ or @0X@ prefix. No leading signs are accepted. +-- Accepts @A..F@, @a..f@, @0..9@ and underscore separators. +hexadecimal :: forall a m. (Eq a, Num a, CharParsing m, Monad m) => m a +hexadecimal = do + void (string "0x" <|> string "0X") + contents <- withUnder hexDigit + let res = readHex contents + case res of + [] -> unexpected ("unparsable hex literal " <> contents) + [(x, "")] -> pure x + _ -> unexpected ("ambiguous hex literal " <> contents) + +-- | Parse a number in octal. +-- +-- Requires a @0@, @0o@ or @0O@ prefix. No leading signs are accepted. +-- Accepts @0..7@ and underscore separators. +octal :: forall a m. (Num a, CharParsing m, Monad m) => m a +octal = do + void (char '0' *> optional (oneOf "oO")) + digs <- withUnder octDigit + fromIntegral <$> attempt @Integer ("0o" <> digs) + +-- | Parse a number in binary. +-- +-- Requires a @0b@ or @0B@ prefix. No leading signs are accepted. +-- Accepts @0@, @1@, and underscore separators. +binary :: forall a m. (Show a, Num a, CharParsing m, Monad m) => m a +binary = do + void (char '0') + void (optional (oneOf "bB")) + digs <- withUnder (oneOf "01") + let c2b c = case c of + '0' -> 0 + '1' -> 1 + x -> error ("Invariant violated: both Attoparsec and readInt let a bad digit through: " <> [x]) + let res = readInt 2 (`elem` "01") c2b digs + case res of + [] -> unexpected ("No parse of binary literal: " <> digs) + [(x, "")] -> pure x + others -> unexpected ("Too many parses of binary literal: " <> show others) + +-- | Parse an arbitrary-precision number with an optional decimal part. +-- +-- Unlike 'scientificP' or Scientific's 'Read' instance, this handles: +-- +-- * omitted whole parts, e.g. @.5@ +-- * omitted decimal parts, e.g. @5.@ +-- * exponential notation, e.g. @3.14e+1@ +-- * numeric parts, in whole or decimal or exponent parts, with @_@ characters +-- * hexadecimal, octal, and binary integer literals, without a decimal part. +-- +-- You may either omit the whole or the leading part, not both; this parser also rejects the empty string. +-- It does /not/ handle hexadecimal floating-point numbers. +floating :: (CharParsing m, Monad m) => m Scientific +floating = signed (choice [hexadecimal, octal, binary, dec]) + where + -- Compared to the binary parser, this is positively breezy. + dec = do + -- Try getting the whole part of a floating literal. + leadings <- stripUnder <$> many (digit <|> char '_') + -- Try reading a dot. + void (optional (char '.')) + -- The trailing part... + trailings <- stripUnder <$> many (digit <|> char '_') + -- ...and the exponent. + exponent <- stripUnder <$> many (oneOf "eE_0123456789+-") + -- Ensure we don't read an empty string, or one consisting only of a dot and/or an exponent. + when (null trailings && null leadings) (unexpected "Does not accept a single dot") + -- Replace empty parts with a zero. + let leads = if null leadings then "0" else leadings + let trail = if null trailings then "0" else trailings + attempt (leads <> "." <> trail <> exponent) + +-- | Converts a numeric parser to one that accepts an optional leading sign. +signed :: forall a m . (CharParsing m, Num a) => m a -> m a +signed p = + (negate <$> (char '-' *> p)) + <|> (char '+' *> p) + <|> p + +-- | Converts a numeric parser to one that accepts a trailing imaginary specifier +-- @i@ or @j@. This does not add facilities for two-valued literals, i.e. @1+4j@, +-- as those are generally best left to high-level expression facilities. +imaginary :: forall a m . (CharParsing m, Monad m, Num a) => m a -> m (Complex a) +imaginary num = do + real <- num + void (oneOf "ij") + pure (0 :+ real) + +stripUnder :: String -> String +stripUnder = Prelude.filter (/= '_') + +attempt :: (Read a, CharParsing m) => String -> m a +attempt str = maybe (unexpected ("No parse: " <> str)) pure (readMaybe str) + +withUnder :: CharParsing m => m Char -> m String +withUnder p = stripUnder <$> ((:) <$> p <*> many (p <|> char '_')) diff --git a/test/Generators.hs b/test/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Generators.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Generators + ( module Generators, + ) +where + +import Data.Ratio ((%)) +import Data.Scientific (Scientific) +import qualified Data.Scientific as Scientific +import Hedgehog +import qualified Hedgehog.Gen as Gen + +integerScientific :: MonadGen m => Hedgehog.Range Integer -> m Scientific +integerScientific = fmap fromIntegral . Gen.integral + +rationalScientific :: MonadGen m => Hedgehog.Range Integer -> Hedgehog.Range Integer -> m Scientific +rationalScientific nrange drange = do + num <- Gen.integral nrange + den <- Gen.integral drange + let goodDen = if den == 0 then 1 else den + let digitLimit = Just 25 + case Scientific.fromRationalRepetend digitLimit (num % goodDen) of + Left (sci, _) -> pure sci + Right (sci, _) -> pure sci + +floatingScientific :: MonadGen m => Hedgehog.Range Double -> m Scientific +floatingScientific = fmap Scientific.fromFloatDigits . Gen.double + +classifyScientific :: MonadTest m => Scientific -> m () +classifyScientific sci = do + classify "negative" $ sci < 0 + classify "small" $ (sci > 0 && sci <= 1) + classify "medium" $ (sci > 1 && sci <= 10000) + classify "large" $ sci > 10000 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main, + ) +where + +import Data.Attoparsec.Text (parseOnly, endOfInput) +import Data.Either +import Data.Foldable (traverse_) +import Data.Scientific +import Data.Foldable (for_) +import Data.Text as Text +import qualified Generators as Gen +import Hedgehog +import qualified Hedgehog.Range as Range +import Numeric.Parse.Flexible as Flex +import qualified Test.Tasty as Tasty +import Test.Tasty.HUnit +import Test.Tasty.HUnit as HUnit +import Test.Tasty.Hedgehog + +-- Integer stuff + +type IFixture = (Text, Integer) + +python :: [IFixture] +python = + [ ("-1", (negate 1)), + ("0xDEAD", 0xDEAD), + ("0XDEAD", 0xDEAD), + ("0o123", 83), + ("0O123", 83), + ("0b001", 1), + ("0B001", 1), + ("1_1", 11), -- underscore syntax is Python 3 only + ("0B1_1", 3), + ("0O1_1", 9) + ] + +ruby :: [IFixture] +ruby = + [ ("0xa_bcd_ef0_123_456_789", 0xabcdef0123456789), + ("01234567", 342391) + ] + +integerTestTree :: Tasty.TestTree +integerTestTree = + let go = traverse_ (\(s, v) -> parseInteger s @?= Right v) + in Tasty.testGroup + "Numeric.Exts" + [ testCase "handles Python integers" (go python), + testCase "handles Ruby integers" (go ruby), + testCase "doesn't accept floats" (isLeft (parseInteger "1.5") @? "Accepted floating-point"), + testCase "doesn't accept empty string" (isLeft (parseInteger "") @? "Accepted integer") + ] + +parseInteger :: Text -> Either String Integer +parseInteger = parseOnly (Flex.integer <* endOfInput) + +parseScientific :: Text -> Either String Scientific +parseScientific = parseOnly (Flex.floating <* endOfInput) + +type SFixture = [(Text, Scientific)] + +testSFixture :: [(Text, Scientific)] -> HUnit.Assertion +testSFixture vals = for_ vals $ \(input, expected) -> assertEqual (Text.unpack input) (parseScientific input) (Right expected) + +pythonSyntax :: SFixture +pythonSyntax = + [ ("-.6_6", -0.66), + ("+.1_1", 0.11), + ("123.4123", 123.4123), + ("1_1.3_1", 11.31), + ("1_1.", 11.0), + ("99E+01", 99e1), + ("3.e14", 3e14), + (".3e1_4", 0.3e14), + ("1_0", 10), + (".3", 0.3), + (".1", 0.1) -- omitting a leading 0 is deprecated in python 3, also note that the -l suffix is not valid in Python 3 + ] + +rubySyntax :: SFixture +rubySyntax = + [ ("1.234_5e1_0", 1.2345e10), + ("1E30", 1e30), + ("1.2", 1.2), + ("1.0e+6", 1.0e6), + ("1.0e-6", 1.0e-6) + ] + +jsSyntax :: SFixture +jsSyntax = + [ ("101", 101), + ("3.14", 3.14), + ("3.14e+1", 3.14e1), + ("0x1ABCDEFabcdef", 470375954370031), + ("0o7632157312", 1047060170), + ("0b1010101001", 681) + ] + +testTree :: Tasty.TestTree +testTree = + Tasty.testGroup + "Data.Scientific.Exts" + [ testCase "Python float syntax" $ testSFixture pythonSyntax, + testCase "Ruby float syntax" $ testSFixture rubySyntax, + testCase "JavaScript float syntax" $ testSFixture jsSyntax, + testCase "Pathological input" $ do + isLeft (parseScientific ".") @? "Accepted period" + isLeft (parseScientific "") @? "Accepted empty string", + testProperty "Scientific roundtripping" . property $ do + let nrange = Range.linear (negate 500000) 20000000 + drange = Range.exponential 1 100000000 + fromRat <- forAll (Gen.rationalScientific nrange drange) + Gen.classifyScientific fromRat + tripping fromRat (pack . show) parseScientific, + testProperty "Double-based Scientific roundtripping" . property $ do + fromDbl <- forAll (Gen.floatingScientific (Range.linearFrac (negate 1) 3)) + Gen.classifyScientific fromDbl + tripping fromDbl (pack . show) parseScientific + ] + +main :: IO () +main = Tasty.defaultMain (Tasty.testGroup "All tests" [testTree, integerTestTree])