Нетрудно придумать функцию, которая делает это правильно. Мы будем просто отрывать по одному символу, используя Data.Map для поиска общих суффиксов:

{-# LANGUAGE FlexibleContexts #-}
import Control.Applicative
import Data.Map hiding (empty)
import Text.Parsec hiding ((<|>))
import Text.Parsec.Char

-- accept the empty string if that's a choice
possiblyEmpty :: Stream s m Char => [String] -> ParsecT s u m String
possiblyEmpty ss | "" `elem` ss = pure ""
                 | otherwise    = empty

chooseFrom :: Stream s m Char => [String] -> ParsecT s u m String
chooseFrom ss
     =  foldWithKey (\h ts parser -> liftA2 (:) (char h) (chooseFrom ts) <|> parser)
                    empty
                    (fromListWith (++) [(h, [t]) | h:t <- ss])
    <|> possiblyEmpty ss

Мы можем проверить в ghci, что он успешно соответствует "tail" и "tales", и что он запрашивает i или l после неудачного синтаксического анализа, начиная с ta:

*Main> parse (chooseFrom ["head", "tail", "tales"]) "" "tail"
Right "tail"
*Main> parse (chooseFrom ["head", "tail", "tales"]) "" "tales"
Right "tales"
*Main> parse (chooseFrom ["head", "tail", "tales"]) "" "tafoo"
Left (line 1, column 3):
unexpected "f"
expecting "i" or "l"

Старый ответ для старого нерабочего примера

Какая версия parsec у вас установлена? 3.1.9 делает это для меня:

Prelude> :m + Text.Parsec Text.Parsec.String
Prelude Text.Parsec Text.Parsec.String> :set prompt Main>
Main> let parser = choice (map (try . string) ["foo", "fob", "bar"]) :: GenParser Char st String
Main> runParser parser () "Hey" "fo "
Left "Hey" (line 1, column 1):
unexpected " "
expecting "foo", "fob" or "bar"
Main> runParser parser () "Hey" "fo"
Left "Hey" (line 1, column 1):
unexpected end of input
expecting "foo", "fob" or "bar"

Добавленный <?> error_message ничего не меняет, кроме того, что он меняет последнюю строку на expecting expected one of ['foo', 'fob', 'bar'].

Как извлечь больше ошибок из Parsec

Так что это один из тех случаев, когда вы не должны полагаться на то, что сообщение об ошибке исчерпывает информацию, доступную в системе. Позвольте мне привести причудливый экземпляр Show для Text.Parsec.Error:Message (который в основном был бы таким, если бы он был deriving (Show)), чтобы вы могли видеть, что выходит из Parsec:

Main> :m + Text.Parsec.Error
Main> instance Show Message where show m = (["SysUnExpect", "UnExpect", "Expect", "Message"] !! fromEnum m) ++ ' ' : show (messageString m)
Main> case runParser parser () "" "ta" of Left pe -> errorMessages pe
[SysUnExpect "\"t\"",SysUnExpect "",SysUnExpect "",Expect "\"head\"",Expect "\"tail\"",Expect "\"tales\""]

Вы можете видеть, что тайно choice сбрасывает всю свою информацию в кучу параллельных сообщений и сохраняет "неожиданный конец файла" как SysUnExpect "". Экземпляр show для ParseError, по-видимому, захватывает первое SysUnExpect, но все сообщения Expect и выводит их для вашего просмотра.

Точная функция, которая делает это в настоящее время, - это Text.Parsec.Error:showErrorMessages. Ожидается, что сообщения об ошибках будут упорядочены и разбиты на 4 части в зависимости от конструктора; чанк SysUnExpect отправляется через специальную функцию отображения, которая полностью скрывает текст, если есть добросовестные элементы UnExpect, или показывает только первое сообщение SysUnExpect:

  showSysUnExpect | not (null unExpect) ||
                    null sysUnExpect = ""
                  | null firstMsg    = msgUnExpected ++ " " ++ msgEndOfInput
                  | otherwise        = msgUnExpected ++ " " ++ firstMsg

Возможно, стоит переписать это или отправить сообщение об ошибке в апстрим, так как это довольно странное поведение, и структуры данных им не совсем подходят. Во-первых, ваша проблема в двух словах: кажется, что каждый Message должен иметь SourcePos, а не каждый ParseError.

Итак, есть более ранний шаг, mergeErrors, который предпочитает ParseErrors с более поздними SourcePos-ами. Это не срабатывает, потому что в сообщениях нет SourcePos, что означает, что все ошибки из choice начинаются с начала строки, а не с максимальной совпавшей точки. Вы можете увидеть это, например, в том, как это не застревает при разборе "tai":

let parser = try (string "head") <|> choice (map (try . (string "ta" >>) . string) ["il", "les"]) :: GenParser Char st Strinh

Во-вторых, помимо этого, возможно, нам следует связать сообщения, которые идут вместе (поэтому сообщение по умолчанию — unexpected 't', expected "heads" | unexpected end-of-file, expected 'tails' | unexpected end-of-file, expected 'tales', если только вы не переопределите его с помощью <?>). В-третьих, вероятно, следует экспортировать конструктор ParseError; в-четвертых, перечисляемый тип в Message действительно уродлив и может быть лучше помещен в ParseError {systemUnexpected :: [Message], userUnexpected :: [Message], expected :: [Message], other :: [Message]} или что-то в этом роде, даже в его нынешнем воплощении. (Например, текущий Show для ParseError слегка сломается, если сообщения не в определенном порядке.)

А пока я бы рекомендовал написать свой вариант show для ParseError.

Вот что у меня получилось с Parsec:

λ> let parser = choice $ fmap (try . string) ["head", "tail", "tales"]
λ> parseTest parser "ta"
parse error at (line 1, column 1):
unexpected "t"
expecting "head", "tail" or "tales"

Если вы захотите попробовать современную версию Parsec — Megaparsec, вы получите:

λ> let parser = choice $ fmap (try . string) ["head", "tail", "tales"]
λ> parseTest parser "ta"
1:1:
unexpected "ta" or 't'
expecting "head", "tail", or "tales"

Что тут происходит? Во-первых, когда мы анализируем упорядоченный набор символов, как с string, мы полностью отображаем неверный ввод. На наш взгляд, это намного лучше, потому что:

λ> parseTest (string "when" <* eof) "well"
1:1:
unexpected "we"
expecting "when"

Мы указываем на начало слова и показываем все, что неверно (до первого несовпадающего символа) и все, что мы ожидаем. На мой взгляд, это более читабельно. Только парсеры, построенные на tokens, работают таким образом (то есть, когда мы пытаемся сопоставить фиксированную строку, доступен вариант без учета регистра).

Тогда как насчет unexpected "ta" or 't', почему мы получаем 't' часть? Это также абсолютно правильно, потому что с вашей коллекцией альтернатив первая буква 't' тоже может быть неожиданной сама по себе, потому что у вас есть альтернатива, которая не начинается с 't'. Давайте посмотрим на другой пример:

λ> let parser = choice $ fmap (try . string) ["tall", "tail", "tales"]
λ> parseTest parser "ta"
1:1:
unexpected "ta"
expecting "tail", "tales", or "tall"

Или как насчет:

λ> parseTest (try (string "lexer") <|> string "lexical") "lex"
1:1:
unexpected "lex"
expecting "lexer" or "lexical"

Парсек:

λ> parseTest (try (string "lexer") <|> string "lexical") "lex"
parse error at (line 1, column 1):
unexpected end of input
expecting "lexical"

Зачем прилагать усилия, чтобы заставить его работать, когда он может «просто работать»?

Есть много других замечательных вещей о Megaparsec, если вам интересно, вы можете узнать больше об этом здесь. Трудно конкурировать с Parsec, но мы написали свои собственные руководства, и наша документация очень хороша.