Merge pull request #178 from natefaubion/fix-stack-safety

Fix stack safety of alt and bind

Author: jamesdbrock

bench/Main.purs

@@ -207,9 +207,8 @@ main = do
     $ \_ -> runParser string23_1000 $ sepByRec anyChar (char '3')
 
   log "<th><h2>sepBy 10000</h2></th>"
-  -- sepBy not stack-safe
-  -- htmlTableWrap "runParser sepBy 10000" $ benchWith 50
-  --   $ \_ -> runParser string23_10000 $ sepBy anyChar (char '3')
+  htmlTableWrap "runParser sepBy 10000" $ benchWith 50
+    $ \_ -> runParser string23_10000 $ sepBy anyChar (char '3')
   htmlTableWrap "runParser sepByRec 10000" $ benchWith 50
     $ \_ -> runParser string23_10000 $ sepByRec anyChar (char '3')
 
@@ -226,9 +225,8 @@ main = do
     $ \_ -> runParser string23_1000 $ chainrRec anyChar (pure const) 'x'
 
   log "<th><h2>chainr 10000</h2></th>"
-  -- chainr not stack-safe
-  -- htmlTableWrap "runParser chainr 10000" $ benchWith 5
-  --   $ \_ -> runParser string23_10000 $ chainr anyChar (pure const) 'x'
+  htmlTableWrap "runParser chainr 10000" $ benchWith 5
+    $ \_ -> runParser string23_10000 $ chainr anyChar (pure const) 'x'
   htmlTableWrap "runParser chainrRec 10000" $ benchWith 5
     $ \_ -> runParser string23_10000 $ chainrRec anyChar (pure const) 'x'
 
@@ -243,14 +241,12 @@ main = do
     $ \_ -> runParser string23_1000x $ manyTillRec_ anyChar (char 'x')
 
   log "<th><h2>manyTill 10000</h2></th>"
-  -- manyTill not stack-safe
-  -- htmlTableWrap "runParser manyTill 10000" $ benchWith 50
-  --   $ \_ -> runParser string23_10000x $ manyTill anyChar (char 'x')
+  htmlTableWrap "runParser manyTill 10000" $ benchWith 50
+    $ \_ -> runParser string23_10000x $ manyTill anyChar (char 'x')
   htmlTableWrap "runParser manyTillRec 10000" $ benchWith 50
     $ \_ -> runParser string23_10000x $ manyTillRec anyChar (char 'x')
-  -- manyTill_ not stack-safe
-  -- htmlTableWrap "runParser manyTill_ 10000" $ benchWith 50
-  --   $ \_ -> runParser string23_10000x $ manyTill_ anyChar (char 'x')
+  htmlTableWrap "runParser manyTill_ 10000" $ benchWith 50
+    $ \_ -> runParser string23_10000x $ manyTill_ anyChar (char 'x')
   htmlTableWrap "runParser manyTillRec_ 10000" $ benchWith 50
     $ \_ -> runParser string23_10000x $ manyTillRec_ anyChar (char 'x')
 

src/Parsing.purs

@@ -220,9 +220,10 @@ instance Bind (ParserT s m) where
     ( mkFn5 \state1 more lift throw done ->
         more \_ ->
           runFn5 k1 state1 more lift throw
-            ( mkFn2 \state2 a -> do
-                let (ParserT k2) = next a
-                runFn5 k2 state2 more lift throw done
+            ( mkFn2 \state2 a ->
+                more \_ -> do
+                  let (ParserT k2) = next a
+                  runFn5 k2 state2 more lift throw done
             )
     )
 
@@ -317,10 +318,11 @@ instance Alt (ParserT s m) where
         more \_ ->
           runFn5 k1 (ParseState input pos false) more lift
             ( mkFn2 \state2@(ParseState _ _ consumed) err ->
-                if consumed then
-                  runFn2 throw state2 err
-                else
-                  runFn5 k2 state1 more lift throw done
+                more \_ ->
+                  if consumed then
+                    runFn2 throw state2 err
+                  else
+                    runFn5 k2 state1 more lift throw done
             )
             done
     )