CPS internals for better performance and stack safety

bench/Json/Common.purs

@@ -0,0 +1,21 @@
+module Bench.Json.Common where
+
+import Prelude
+
+import Data.Generic.Rep (class Generic)
+import Data.List (List)
+import Data.Show.Generic (genericShow)
+import Data.Tuple (Tuple)
+
+data Json
+  = JsonNull
+  | JsonNumber Number
+  | JsonString String
+  | JsonBoolean Boolean
+  | JsonArray (List Json)
+  | JsonObject (List (Tuple String Json))
+
+derive instance Generic Json _
+
+instance Show Json where
+  show a = genericShow a

bench/Json/Parsing.purs

@@ -0,0 +1,58 @@
+module Bench.Json.Parsing where
+
+import Prelude hiding (between)
+
+import Bench.Json.Common (Json(..))
+import Control.Lazy (defer)
+import Data.List (List)
+import Data.Maybe (Maybe(..))
+import Data.Number as Number
+import Data.Tuple (Tuple(..))
+import Text.Parsing.Parser (Parser, fail)
+import Text.Parsing.Parser.Combinators (between, choice, sepBy, try)
+import Text.Parsing.Parser.String (regex, skipSpaces, string)
+
+json :: Parser String Json
+json = defer \_ ->
+  skipSpaces *> choice
+    [ JsonObject <$> jsonObject
+    , JsonArray <$> jsonArray
+    , JsonString <$> jsonString
+    , JsonNumber <$> jsonNumber
+    , JsonBoolean <$> jsonBoolean
+    , JsonNull <$ jsonNull
+    ]
+
+jsonObject :: Parser String (List (Tuple String Json))
+jsonObject = defer \_ ->
+  between (string "{") (skipSpaces *> string "}") do
+    skipSpaces *> jsonObjectPair `sepBy` (try (skipSpaces *> string ","))
+
+jsonObjectPair :: Parser String (Tuple String Json)
+jsonObjectPair = defer \_ ->
+  Tuple <$> (skipSpaces *> jsonString <* skipSpaces <* string ":") <*> json
+
+jsonArray :: Parser String (List Json)
+jsonArray = defer \_ ->
+  between (string "[") (skipSpaces *> string "]") do
+    json `sepBy` (try (skipSpaces *> string ","))
+
+jsonString :: Parser String String
+jsonString = between (string "\"") (string "\"") do
+  regex {} """\\"|[^"]*"""
+
+jsonNumber :: Parser String Number
+jsonNumber = do
+  n <- regex {} """(\+|-)?(\d+(\.\d*)?|\d*\.\d+)([eE](\+|-)?\d+)?"""
+  case Number.fromString n of
+    Just n' -> pure n'
+    Nothing -> fail "Expected number"
+
+jsonBoolean :: Parser String Boolean
+jsonBoolean = choice
+  [ true <$ string "true"
+  , false <$ string "false"
+  ]
+
+jsonNull :: Parser String String
+jsonNull = string "null"

bench/Json/StringParsers.purs

@@ -0,0 +1,58 @@
+module Bench.Json.StringParser where
+
+import Prelude hiding (between)
+
+import Bench.Json.Common (Json(..))
+import Control.Lazy (defer)
+import Data.List (List)
+import Data.Maybe (Maybe(..))
+import Data.Number as Number
+import Data.Tuple (Tuple(..))
+import StringParser (Parser, fail, try)
+import StringParser.CodePoints (regex, skipSpaces, string)
+import StringParser.Combinators (between, choice, sepBy)
+
+json :: Parser Json
+json = defer \_ ->
+  skipSpaces *> choice
+    [ JsonObject <$> jsonObject
+    , JsonArray <$> jsonArray
+    , JsonString <$> jsonString
+    , JsonNumber <$> jsonNumber
+    , JsonBoolean <$> jsonBoolean
+    , JsonNull <$ jsonNull
+    ]
+
+jsonObject :: Parser (List (Tuple String Json))
+jsonObject = defer \_ ->
+  between (string "{") (skipSpaces *> string "}") do
+    skipSpaces *> jsonObjectPair `sepBy` (try (skipSpaces *> string ","))
+
+jsonObjectPair :: Parser (Tuple String Json)
+jsonObjectPair = defer \_ ->
+  Tuple <$> (skipSpaces *> jsonString <* skipSpaces <* string ":") <*> json
+
+jsonArray :: Parser (List Json)
+jsonArray = defer \_ ->
+  between (string "[") (skipSpaces *> string "]") do
+    json `sepBy` (try (skipSpaces *> string ","))
+
+jsonString :: Parser String
+jsonString = between (string "\"") (string "\"") do
+  regex """\\"|[^"]*"""
+
+jsonNumber :: Parser Number
+jsonNumber = do
+  n <- regex """(\+|-)?(\d+(\.\d*)?|\d*\.\d+)([eE](\+|-)?\d+)?"""
+  case Number.fromString n of
+    Just n' -> pure n'
+    Nothing -> fail "Expected number"
+
+jsonBoolean :: Parser Boolean
+jsonBoolean = choice
+  [ true <$ string "true"
+  , false <$ string "false"
+  ]
+
+jsonNull :: Parser String
+jsonNull = string "null"

bench/Json/TestData.purs

@@ -0,0 +1,27 @@
+module Bench.Json.TestData where
+
+import Prelude
+
+import Data.Array (replicate)
+import Data.String (joinWith)
+
+jsonProps :: String
+jsonProps =
+  """
+    "some_number": 42.00009
+  , "some_string": "foobarbazquux"
+  , "some_null": null
+  , "some_boolean": true
+  , "some_other_boolean": false
+  , "some_array": [ 1, 2, "foo", true, 99 ]
+  , "some_object": { "foo": 42, "bar": "wat", "baz": false }
+  """
+
+smallJson :: String
+smallJson = "{" <> jsonProps <> "}"
+
+mediumJson :: String
+mediumJson = "{" <> joinWith ", " (replicate 30 jsonProps) <> "}"
+
+largeJson :: String
+largeJson = "[" <> joinWith ", " (replicate 100 smallJson) <> "]"

bench/Main.purs

@@ -41,9 +41,12 @@ module Bench.Main where
 
 import Prelude
 
+import Bench.Json.Parsing as BenchParsing
+import Bench.Json.StringParser as BenchStringParser
+import Bench.Json.TestData (largeJson, mediumJson, smallJson)
 import Data.Array (fold, replicate)
 import Data.Either (either)
-import Data.List (manyRec)
+import Data.List (many, manyRec)
 import Data.List.Types (List)
 import Data.String.Regex (Regex, regex)
 import Data.String.Regex as Regex
@@ -56,9 +59,9 @@ import Performance.Minibench (benchWith)
 import Text.Parsing.Parser (Parser, runParser)
 import Text.Parsing.Parser.String (string)
 import Text.Parsing.Parser.String.Basic (digit)
-import Text.Parsing.StringParser as StringParser
-import Text.Parsing.StringParser.CodePoints as StringParser.CodePoints
-import Text.Parsing.StringParser.CodeUnits as StringParser.CodeUnits
+import StringParser as StringParser
+import StringParser.CodePoints as StringParser.CodePoints
+import StringParser.CodeUnits as StringParser.CodeUnits
 
 string23 :: String
 string23 = "23"
@@ -100,7 +103,7 @@ pattern23 = either (unsafePerformEffect <<< throw) identity
       }
 
 parseSkidoo :: Parser String (List String)
-parseSkidoo = manyRec $ string "skidoo"
+parseSkidoo = many $ string "skidoo"
 
 patternSkidoo :: Regex
 patternSkidoo = either (unsafePerformEffect <<< throw) identity
@@ -138,3 +141,27 @@ main = do
   log "Regex.match patternSkidoo"
   benchWith 200
     $ \_ -> Regex.match patternSkidoo stringSkidoo_10000
+
+  log "runParser json smallJson"
+  benchWith 1000
+    $ \_ -> runParser smallJson BenchParsing.json
+
+  log "StringParser.runParser json smallJson"
+  benchWith 1000
+    $ \_ -> StringParser.runParser BenchStringParser.json smallJson
+
+  log "runParser json mediumJson"
+  benchWith 500
+    $ \_ -> runParser mediumJson BenchParsing.json
+
+  log "StringParser.runParser json mediumJson"
+  benchWith 500
+    $ \_ -> StringParser.runParser BenchStringParser.json mediumJson
+
+  log "runParser json largeJson"
+  benchWith 100
+    $ \_ -> runParser largeJson BenchParsing.json
+
+  log "StringParser.runParser json largeJson"
+  benchWith 100
+    $ \_ -> StringParser.runParser BenchStringParser.json largeJson

packages.dhall

@@ -1,4 +1,4 @@
 let upstream =
-      https://github.com/purescript/package-sets/releases/download/psc-0.14.3-20210722/packages.dhall sha256:1ceb43aa59436bf5601bac45f6f3781c4e1f0e4c2b8458105b018e5ed8c30f8c
+      https://github.com/purescript/package-sets/releases/download/psc-0.14.7-20220320/packages.dhall sha256:523f5eed3b3d8c7b04b6fcb2b60b1421c06eeb26b2fedae0bd9ddcfebaf0a919
 
 in  upstream

spago-dev.dhall

@@ -12,6 +12,7 @@ in conf //
 , dependencies = conf.dependencies #
   [ "assert"
   , "console"
+  , "enums"
   , "effect"
   , "psci-support"
   , "minibench"

spago.dhall

@@ -5,14 +5,18 @@
   [ "arrays"
   , "control"
   , "either"
+  , "enums"
   , "foldable-traversable"
+  , "functions"
   , "identity"
   , "integers"
+  , "lazy"
   , "lists"
   , "math"
   , "maybe"
   , "newtype"
   , "numbers"
+  , "partial"
   , "prelude"
   , "record"
   , "strings"
@@ -21,7 +25,6 @@
   , "tuples"
   , "unfoldable"
   , "unicode"
-  , "unsafe-coerce"
   ]
 , packages = ./packages.dhall
 , sources = [ "src/**/*.purs" ]