PackratParsing.hs

import Data.Maybe
import Control.Applicative
import Control.Monad
import Data.Char (isSpace, digitToInt)
import Debug.Trace

main :: IO ()
main = print . runParser $ "(1+2-3*4)*2"

runParser :: String -> Maybe Int
runParser s = fmap fst $ msum $ [dvMultitive, dvPrimary, dvDecimal, dvAdditive] <*> [parse s 0]

newtype Parser v = Parser (Derivs -> Result v)

type Result v = Maybe (v, Derivs)

data Derivs = Derivs
  { dvAdditive :: Result Int
  , dvAdditiveSuffix :: Result (Int -> Int)
  , dvMultitive :: Result Int
  , dvPrimary :: Result Int
  , dvDecimal :: Result Int
  , dvSymbol :: Result Char
  , dvSpacing :: Result ()
  , dvChar :: Result Char
  , depth :: Int
  }

instance Monad Parser where
  (Parser p) >>= f = Parser $ \d -> case p d of
    Just (v, d') -> let Parser p' = f v in p' d'
    Nothing -> Nothing
  return v = Parser $ \d -> Just (v, d)
  fail msg = Parser $ \d -> Nothing

instance MonadPlus Parser where
  mzero = fail ""
  Parser p1 `mplus` Parser p2 = Parser $ \d -> case p1 d of
    r@(Just _) -> r
    Nothing -> case p2 d of
      r@(Just _) -> r
      Nothing -> Nothing

(</>) = mplus

parse :: String -> Int -> Derivs
parse s depth = d where
  d = Derivs add asuf mult prim dec sym spc chr depth
  add  = trace ("*** Derivs[" ++ (show depth) ++ "] add ***")  $ pAdditive d
  asuf = trace ("*** Derivs[" ++ (show depth) ++ "] asuf ***") $ pAdditiveSuffix d
  mult = trace ("*** Derivs[" ++ (show depth) ++ "] mult ***") $ pMultitive d
  prim = trace ("*** Derivs[" ++ (show depth) ++ "] prim ***") $ pPrimary d
  dec  = trace ("*** Derivs[" ++ (show depth) ++ "] dec ***")  $ pDecimal d
  sym  = trace ("*** Derivs[" ++ (show depth) ++ "] sym ***")  $ pSymbol d
  spc  = trace ("*** Derivs[" ++ (show depth) ++ "] spc ***")  $ pSpacing d
  chr  = trace ("*** Derivs[" ++ (show depth) ++ "] chr ***")  $ case s of
    (c:s') -> trace (show c) $ Just (c, parse s' $ depth + 1)
    [] -> Nothing

char :: Char -> Parser Char
char c = Parser $ \d -> case dvSymbol d of
  r@(Just (v, _)) -> if c == v then r else Nothing
  Nothing -> Nothing

pAdditive :: Derivs -> Result Int
Parser pAdditive = do
  l <- Parser dvMultitive
  f <- Parser dvAdditiveSuffix
  return $ f l

pAdditiveSuffix :: Derivs -> Result (Int -> Int)
Parser pAdditiveSuffix = alt1 </> alt2 </> return id
  where 
    alt1 = do
      char '+'
      r <- Parser dvMultitive
      f <- Parser dvAdditiveSuffix
      return $ f . \x -> x + r
    alt2 = do
      char '-'
      r <- Parser dvMultitive
      f <- Parser dvAdditiveSuffix
      return $ f . \x -> x - r

pMultitive :: Derivs -> Result Int
Parser pMultitive = alt1 </> do Parser dvPrimary
  where
    alt1 = do
      l <- Parser dvPrimary
      char '*'
      r <- Parser dvMultitive
      return $ l * r

pPrimary :: Derivs -> Result Int
Parser pPrimary = alt1 </> do Parser dvDecimal
  where
    alt1 = do
      char '('
      v <- Parser dvAdditive
      char ')'
      return v

pDecimal :: Derivs -> Result Int
Parser pDecimal = do
  c <- Parser dvChar
  guard $ c `elem` ['0'..'9']
  return $ digitToInt c

pSpacing :: Derivs -> Result ()
Parser pSpacing = do
  c <- Parser dvChar
  if isSpace c
    then Parser dvSpacing
    else return ()

pSymbol :: Derivs -> Result Char
Parser pSymbol = do
  c <- Parser dvChar
  guard $ c `elem` "+-*/%()"
  return c

From "Packrat Parsing: a Practical Linear-Time Algorithm with Backtracking" by Bryan Ford

• 3.1.4 Packrat Parsing
• 3.2.1 Left Recursion
• 3.2.2 Integrated Lexical Analysis
• 3.2.3 Monadic Packrat Parsing