Choosing out of multiple correct parsers on a single input

I would like to know the best way of parsing an input where multiple parsers can succeed. I have outlined my first failed attempt and an inelegant solution which I hope can be made more idiomatic.

For instance I would like to lex "the", "quick" and "fox" from the following sentence into their own data constructors:

"the quick brown fox jumps over the lazy dog".

So given the following type constructors:

data InterestingWord = Quick | The | Fox deriving Show
data Snippet = Word InterestingWord | Rest String deriving Show

I would like the output of the parse to be:

[Word The,
 Rest " ", Word Quick,
 Rest " brown ", Word Fox,
 Rest " jumped over ", Word The,
 Rest " lazy dog"]

Here are the two solutions:

import Text.Parsec
import Data.Maybe
import Data.Ord    
import Data.List

data InterestingWord = Quick | The | Fox deriving Show
data Snippet = Word InterestingWord | Rest String deriving Show

testCase = "the quick brown fox jumped over the lazy dog"
-- Expected output:
-- [Word The,
--  Rest " ", Word Quick,
--  Rest " brown ", Word Fox,
--  Rest " jumped over ", Word The,
--  Rest " lazy dog"]

toString Quick = "quick"
toString The = "the"
toString Fox = "fox"

-- First attempt

-- Return characters upto the intended word along
-- with the word itself
upto word = do
  pre <- manyTill anyChar $ lookAhead $ string (toString word)
  word' <- try $ string (toString word)
  return [Rest pre, Word word]

-- Parsers for the interesting words
parsers = [upto Quick,
           upto The, 
           upto Fox]

-- Try each parser and return its results with the 
-- rest of the input.
-- An incorrect result is produced because "choice"
-- picks the first successful parse result.
wordParser = do
  snippets <- many $ try $ choice parsers
  leftOver <- many anyChar
  return $ concat $ snippets ++ [[Rest leftOver]]

-- [Rest "the ",Word Quick,Rest " brown fox jumped over the lazy dog"]        
test1 = parseTest wordParser testCase

-- Correct

-- In addition to the characters leading upto the 
-- word and the word, the position is also returned
upto' word = do
  result <- upto word
  pos <- getPosition
  return (pos, result)

-- The new parsers         
parsers' = [upto' Quick,
            upto' The, 
            upto' Fox]

-- Try each of the given parsers and 
-- possibly returning the results and
-- the parser but don't consume
-- input.
tryAll = mapM (\p -> do
                 r <- optionMaybe $ try (lookAhead p)
                 case r of
                   Just result -> return $ Just (p, result)
                   Nothing -> return $ Nothing
              )

-- Pick the parser that has consumed the least.             
firstSuccess ps = do
  successes <- tryAll ps >>= return . catMaybes
  if not (null successes) then
      return $ Just (fst $ head (sortBy (comparing (\(_,(pos,_)) -> pos)) successes))
  else return $ Nothing

-- Return the parse results for the parser that 
-- has consumed the least
wordParser' = do
  parser <- firstSuccess parsers'
  case parser of
    Just p -> do
      (_,snippet) <- p
      return snippet
    Nothing -> parserZero

-- Returns the right result
test2 = parseTest (many wordParser' >>= return . concat) testCase

The first attempt "test1" does not produce the desired output because "choice" returns the first parser that succeeds when what I really want is the first parser that succeeds while consuming the least characters. This is what I try next by holding onto the source position of once input has been parsed and using the parser with the lowest source position.

This case seems common enough that I feel I'm missing some obvious combinator incantation. Can anyone offer better suggestions?

Thanks!

-deech

Solution

This is not a particularly common need, but here's an implementation:

import Control.Monad
import "parsec3" Text.Parsec
import Data.Maybe
import Data.List
import Data.Ord

longestParse :: [Parsec String () a] -> Parsec String () a
longestParse parsers = do
  allParses <- sequence [lookAhead $ optionMaybe $ try $ 
    liftM2 (,) parse getPosition | parse <- parsers]
  -- allParses :: [Maybe (a, SourcePos)]
  (bestParse, bestPos) <- case catMaybes allParses of
    [] -> fail "No valid parse" -- maybe we can do something better?
    successfulParses -> return $ minimumBy (comparing snd) successfulParses
  setPosition bestPos
  return bestParse