diff --git a/Parser.hs b/Parser.hs index afc59fd..154b6c6 100644 --- a/Parser.hs +++ b/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 diff --git a/RParser.hs b/RParser.hs index 7ce177c..5e0ec6d 100644 --- a/RParser.hs +++ b/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"]