Skip to content

Commit

Permalink
Resolve #998. Drop attoparsec.Number instances.
Browse files Browse the repository at this point in the history
More fore: Drop `attoparsec` dependency alltogether.

We parse scientific from Text manually now.
Notice, `scientific` parser in `attoparsec` is quadratic (uses
`decimal`).
haskell/attoparsec#217
  • Loading branch information
phadej committed Jun 9, 2023
1 parent 7b14853 commit bb36c0d
Show file tree
Hide file tree
Showing 5 changed files with 120 additions and 21 deletions.
1 change: 1 addition & 0 deletions .hlint.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@
name: "Avoid lambda"
within:
- Data.Time.FromText
- Data.Aeson.Internal.Scientific
- ignore:
name: "Use isDigit"
within:
Expand Down
5 changes: 2 additions & 3 deletions aeson.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -76,6 +76,7 @@ library
Data.Aeson.Internal.ByteString
Data.Aeson.Internal.Functions
Data.Aeson.Internal.Prelude
Data.Aeson.Internal.Scientific
Data.Aeson.Internal.Text
Data.Aeson.Internal.TH
Data.Aeson.Internal.Unescape
Expand Down Expand Up @@ -109,8 +110,7 @@ library

-- Other dependencies
build-depends:
attoparsec >=0.14.2 && <0.15
, data-fix >=0.3.2 && <0.4
data-fix >=0.3.2 && <0.4
, dlist >=1.0 && <1.1
, hashable >=1.3.5.0 && <1.5
, indexed-traversable >=0.1.2 && <0.2
Expand Down Expand Up @@ -171,7 +171,6 @@ test-suite aeson-tests

build-depends:
aeson
, attoparsec
, base
, base-compat
, base-orphans >=0.5.3 && <0.10
Expand Down
113 changes: 113 additions & 0 deletions src/Data/Aeson/Internal/Scientific.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,113 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Aeson.Internal.Scientific (
scanScientific,
) where

import Data.Integer.Conversion (textToInteger)
import Data.Scientific (Scientific)
import Data.Text (Text)

import qualified Data.Scientific as Sci
import qualified Data.Text as T

-- | Parse 'Scientific' number from 'Text'.
--
-- This is different from how JSON numbers are parsed: arbitrary leading zeroes are accepted.
--
scanScientific
:: forall r. (Scientific -> Text -> r)
-> (String -> r)
-> Text
-> r
scanScientific kont err input0 = case T.uncons input0 of
Nothing -> errEnd
Just (c, text')
| c == '+' -> scanScientific' kont err text'
| c == '-' -> scanScientific' (\sci -> kont (negate sci)) err text'
| otherwise -> scanScientific' kont err input0
where
errEnd = err "Unexpected end-of-input while parsing number literal"

scanScientific'
:: forall r. (Scientific -> Text -> r)
-> (String -> r)
-> Text
-> r
scanScientific' kont err input0 = state_start input0 where
state_start :: Text -> r
state_start !text = case T.uncons text of
Nothing -> errEnd
Just (c, text')
| '0' <= c, c <= '9' -> state_i 1 text'
| otherwise -> err $ "Unexpected " ++ show c ++ " while parsing number literal"

state_i :: Int -> Text -> r
state_i !n !text = case T.uncons text of
Nothing -> kont (fromInteger int) text
Just (c, text')
| '0' <= c, c <= '9' -> state_i (n + 1) text'
| '.' == c -> go_dec int text'
| 'e' == c || 'E' == c -> go_sci int 0 text'
| otherwise -> kont (fromInteger int) text
where
int = textToInteger (T.take n input0)

go_dec :: Integer -> Text -> r
go_dec !int !text1 = case T.uncons text1 of
Nothing -> errEnd
Just (c, text')
| '0' <= c, c <= '9' -> state_dec 1 text'
| otherwise -> err $ "Unexpected " ++ show c ++ " while parsing number literal"
where
state_dec :: Int -> Text -> r
state_dec !n !text = case T.uncons text of
Nothing -> kont dec text
Just (c, text')
| '0' <= c, c <= '9' -> state_dec (n + 1) text'
| 'e' == c || 'E' == c -> go_sci coef (negate n) text'
| otherwise -> kont dec text
where
frac = textToInteger (T.take n text1)
coef = int * 10 ^ n + frac
dec = Sci.scientific coef (negate n)

go_sci :: Integer -> Int -> Text -> r
go_sci !coef !exp10 !text2 = case T.uncons text2 of
Nothing -> errEnd
Just (c, text')
| '0' <= c, c <= '9' -> go_sci_pos coef exp10 text2 1 text'
| '+' == c -> case T.uncons text' of
Nothing -> errEnd
Just (c', text'')
| '0' <= c', c' <= '9' -> go_sci_pos coef exp10 text' 1 text''
| otherwise -> errUnx c'
| '-' == c -> case T.uncons text' of
Nothing -> errEnd
Just (c', text'')
| '0' <= c', c' <= '9' -> go_sci_neg coef exp10 text' 1 text''
| otherwise -> errUnx c'
| otherwise -> errUnx c

go_sci_pos :: Integer -> Int -> Text -> Int -> Text -> r
go_sci_pos !coef !exp10 !text2 !n !text = case T.uncons text of
Nothing -> kont sci text
Just (c, text')
| '0' <= c, c <= '9' -> go_sci_pos coef exp10 text2 (n + 1) text'
| otherwise -> kont sci text
where
exp10' = fromInteger (textToInteger (T.take n text2))
sci = Sci.scientific coef (exp10 + exp10')

go_sci_neg :: Integer -> Int -> Text -> Int -> Text -> r
go_sci_neg !coef !exp10 !text2 !n !text = case T.uncons text of
Nothing -> kont sci text
Just (c, text')
| '0' <= c, c <= '9' -> go_sci_neg coef exp10 text2 (n + 1) text'
| otherwise -> kont sci text
where
exp10' = fromInteger (textToInteger (T.take n text2))
sci = Sci.scientific coef (exp10 - exp10')

errEnd = err "Unexpected end-of-input while parsing number literal"
errUnx c = err $ "Unexpected " ++ show c ++ " while parsing number literal"
9 changes: 4 additions & 5 deletions src/Data/Aeson/Types/FromJSON.hs
Original file line number Diff line number Diff line change
Expand Up @@ -79,6 +79,7 @@ import Data.Aeson.Internal.Prelude

import Control.Monad (zipWithM)
import Data.Aeson.Internal.Functions (mapKey, mapKeyO)
import Data.Aeson.Internal.Scientific
import Data.Aeson.Types.Generic
import Data.Aeson.Types.Internal
import Data.Aeson.Decoding.ByteString.Lazy
Expand Down Expand Up @@ -116,7 +117,6 @@ import Unsafe.Coerce (unsafeCoerce)
import qualified Data.Aeson.Parser.Time as Time
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
import qualified Data.ByteString.Lazy as L
import qualified Data.DList as DList
import qualified Data.DList.DNonEmpty as DNE
Expand Down Expand Up @@ -199,10 +199,9 @@ parseBoundedIntegral name =
prependContext name . withScientific' parseBoundedIntegralFromScientific

parseScientificText :: Text -> Parser Scientific
parseScientificText
= either fail pure
. A.parseOnly (A.scientific <* A.endOfInput)
. T.encodeUtf8
parseScientificText = scanScientific
(\sci rest -> if T.null rest then return sci else fail $ "Expecting end-of-input, got " ++ show (T.take 10 rest))
fail

parseIntegralText :: Integral a => String -> Text -> Parser a
parseIntegralText name t =
Expand Down
13 changes: 0 additions & 13 deletions src/Data/Aeson/Types/ToJSON.hs
Original file line number Diff line number Diff line change
Expand Up @@ -15,9 +15,6 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- TODO: Drop this when we remove support for Data.Attoparsec.Number
{-# OPTIONS_GHC -fno-warn-deprecations #-}

module Data.Aeson.Types.ToJSON
(
-- * Core JSON classes
Expand Down Expand Up @@ -66,7 +63,6 @@ import Data.Aeson.Types.Generic (AllNullary, False, IsRecord, One, ProductSize,
import Data.Aeson.Types.Internal
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import Data.Attoparsec.Number (Number(..))
import Data.Bits (unsafeShiftR)
import Data.DList (DList)
import Data.Fixed (Fixed, HasResolution, Nano)
Expand Down Expand Up @@ -1332,15 +1328,6 @@ instance ToJSON Double where
instance ToJSONKey Double where
toJSONKey = toJSONKeyTextEnc E.doubleText


instance ToJSON Number where
toJSON (D d) = toJSON d
toJSON (I i) = toJSON i

toEncoding (D d) = toEncoding d
toEncoding (I i) = toEncoding i


instance ToJSON Float where
toJSON = realFloatToJSON
toEncoding = E.float
Expand Down

0 comments on commit bb36c0d

Please sign in to comment.