From f7db248293957d0e064dfde5e918e6dea102ffc6 Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Wed, 6 Sep 2023 15:34:21 -0700
Subject: [PATCH] Add recursive wrapper

---
 Parser.hs  | 10 +++++++---
 RParser.hs | 42 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 49 insertions(+), 3 deletions(-)
 create mode 100644 RParser.hs

diff --git a/Parser.hs b/Parser.hs
index 20f387e..afc59fd 100644
--- a/Parser.hs
+++ b/Parser.hs
@@ -4,9 +4,11 @@
 --  class
 --  * Switch from unordered-containers to containers, to reduce dependencies
 --  * Use `Any` and `unsafeCoerce` in `memoise` to remove the restriction that
---  all memoized productions need to have the same type. We cannot use
---  `Data.Dynamic` because we cannot afford extra constraints on `a`, else we
---  cannot instantiate `Functor` for the recursive parser.
+--    all memoized productions need to have the same type. We cannot use
+--    `Data.Dynamic` because we cannot afford extra constraints on `a`, else we
+--    cannot instantiate `Functor` for the recursive parser.
+--  * Removed `Monad` instance.  Unclear if you want that in the kind of parsers
+--    we are looking at.
 
 {-# LANGUAGE ScopedTypeVariables #-}
 module Parser
@@ -72,10 +74,12 @@ newtype Parser k tok a =
              M k tok b [b]
     }
 
+{-
 instance Monad (Parser k tok) where
   return    = pure
   P p >>= f = P $ \input i k ->
     p input i $ \j x -> unP (f x) input j k
+-}
 
 instance Functor (Parser k tok) where
   fmap f (P p) = P $ \input i k ->
diff --git a/RParser.hs b/RParser.hs
new file mode 100644
index 0000000..7ce177c
--- /dev/null
+++ b/RParser.hs
@@ -0,0 +1,42 @@
+module RParser (Parser, parse, sat', sat, token, tok) where
+
+import Data.Unique
+import Data.Typeable
+import System.IO.Unsafe
+import Control.Applicative
+
+import qualified Parser as P
+
+newtype Parser tok a = MkP (P.Parser Unique tok a)
+
+withMemo :: P.Parser Unique tok a -> Parser tok a
+withMemo p = unsafePerformIO $ do
+    u <- newUnique
+    pure $ MkP $ P.memoise u p
+
+parse :: Parser tok a -> [tok] -> [a]
+parse (MkP p) = P.parse p
+
+sat' :: Typeable a => (tok -> Maybe a) -> Parser tok a
+sat' p = MkP (P.sat' p)
+
+sat :: Typeable tok => (tok -> Bool) -> Parser tok tok
+sat p = MkP (P.sat p)
+
+token :: Typeable tok => Parser tok tok
+token = MkP P.token
+
+tok :: Eq tok => tok -> Parser tok tok
+tok t = MkP (P.tok t)
+
+instance Functor (Parser tok) where
+  fmap f (MkP p) = withMemo (fmap f p)
+
+instance Applicative (Parser tok) where
+  pure x = MkP (pure x)
+  MkP p1 <*> MkP p2 = withMemo (p1 <*> p2)
+
+instance Alternative (Parser tok) where
+  empty = MkP empty
+  MkP p1 <|> MkP p2 = withMemo (p1 <|> p2)
+