More lazy!

Parser.hs

@@ -74,12 +74,10 @@ 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 ->
@@ -97,21 +95,6 @@ instance Alternative (Parser k tok) where
   P p1 <|> P p2 = P $ \input i k ->
     liftM2 (++) (p1 input i k) (p2 input i k)
 
--- | Parses a token satisfying the given predicate.
-
-sat :: (tok -> Bool) -> Parser k tok tok
-sat p = sat' (\t -> if p t then Just t else Nothing)
-
--- | Parses a single token.
-
-token :: Parser k tok tok
-token = sat' Just
-
--- | Parses a given token.
-
-tok :: Eq tok => tok -> Parser k tok tok
-tok t = sat (t ==)
-
 parse :: Parser k tok a -> [tok] -> [a]
 parse p toks =
   flip evalState IntMap.empty $
@@ -128,6 +111,21 @@ sat' p = P $ \input i k ->
   else
     return []
 
+-- | Parses a token satisfying the given predicate.
+
+sat :: (tok -> Bool) -> Parser k tok tok
+sat p = sat' (\t -> if p t then Just t else Nothing)
+
+-- | Parses a single token.
+
+token :: Parser k tok tok
+token = sat' Just
+
+-- | Parses a given token.
+
+tok :: Eq tok => tok -> Parser k tok tok
+tok t = sat (t ==)
+
 memoise :: forall k tok a. Ord k => k -> Parser k tok a -> Parser k tok a
 memoise key p = P $ \input i k -> do
 

RParser.hs

@@ -7,7 +7,7 @@ import Control.Applicative
 
 import qualified Parser as P
 
-newtype Parser tok a = MkP (P.Parser Unique tok a)
+data Parser tok a = MkP { unP :: P.Parser Unique tok a }
 
 withMemo :: P.Parser Unique tok a -> Parser tok a
 withMemo p = unsafePerformIO $ do
@@ -30,13 +30,33 @@ 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)
+  fmap f p = withMemo (fmap f (unP p))
 
 instance Applicative (Parser tok) where
   pure x = MkP (pure x)
-  MkP p1 <*> MkP p2 = withMemo (p1 <*> p2)
+  p1 <*> p2 = withMemo (unP p1 <*> unP p2)
+
+instance Monad (Parser tok) where
+  return = pure
+  p1 >>= f = withMemo $ unP p1 >>= unP . f
 
 instance Alternative (Parser tok) where
   empty = MkP empty
-  MkP p1 <|> MkP p2 = withMemo (p1 <|> p2)
+  p1 <|> p2 = withMemo (unP p1 <|> unP p2)
+
+-- The large example from https://okmij.org/ftp/Haskell/LeftRecursion.hs
+
+(>>>) :: Monoid a => Parser tok a -> Parser tok a -> Parser tok a
+p1 >>> p2 = liftA2 (<>) p1 p2
+
+char :: Char -> Parser Char String
+char a = pure <$> tok a
+
+s,a,b,c :: Parser Char String
+s = s >>> a >>> c <|> c
+a = b <|> char 'a' >>> c >>> char 'a'
+b = id <$> b
+c = char 'b' <|> c >>> a
 
+-- ghci> parse s "babababa"
+-- ["babababa"]