Зададим грамматику сбалансированных скобок.

Рассмотрим упрощенную версию, когда и терминалы, и нетерминалы будут
представлены символами из Char.

терминалы: ()
нетерминал: S

S -> ()|(S)|SS

Для дальнейшего описания нам потребуется техника монад.

\begin{code}
import Control.Monad
import Data.Maybe
\end{code}

Проверим наличие только скобок во входной строке.

\begin{code}
checksymb :: Char -> Char
checksymb  c | (c `elem` "()")     =  c
             | otherwise = error "There is an illegal symbol!"
\end{code}


Опишем продукционные правила как функции свёртки:

\begin{code}
prodrule :: String -> Maybe Char
prodrule "()"  = Just 'S'
prodrule "(S)" = Just 'S'
prodrule "SS"  = Just 'S'
prodrule _     = Nothing
\end{code}


Воспользуемся общей схемой "восходящего анализатора".

0. На вход для анализа получаем строку символов. 
В нашем представлении это будет список (стек) [Char], его символизирует переменная ss.
Проектируемый парсер будет работать с парой (String,String) у которой первый элемент --- входная 
(точнее --- укорачиваемая текущая строка), а второй элемент --- 
строка-магазин mss обрабатываемых на каждом шагу нетерминалов.

1. Отщепляем первый элемент s списка.
И, прежде чем поместить его в магазин mss, проверяем его на корректность.

\begin{code}
transfer :: (String,String) -> (String,String)
transfer ((s:ss),mss) = (ss, ((checksymb s):mss))
transfer ([],m)       = ([], m)
\end{code}

Поместим его в магазин. 

2. Пара <<технических>> функций. Функция justadd2list
передаст результат удачно выполненной продукции обратно в магазин
(или выставит флаг Nothing в случае неудачи) и обернёт его монадой Maybe. 
Функция mmplus действует немного подобно своей тёзке mplus из MonadPlus:
соединяя два аргумента --- пары (входная строка, магазин), причём в первом 
аргументе-паре магазин обёрнут монадой Maybe. В соответствии с обёрткой, если она Nothing, то
возвращаем второй аргумент, если (Just mss), то снимаем обёртку и возвращаем значение
первого аргумента.

\begin{code}
justadd2list :: Maybe a -> [a] -> Maybe [a]
(Just x) `justadd2list` mss   = Just (x:mss)
Nothing  `justadd2list` _     = Nothing

mmplus :: (t, Maybe t1) -> (t,t1) -> (t,t1)
(_,  Nothing)  `mmplus` t  = t
(ss, Just mss) `mmplus` _  = (ss,mss)
\end{code}

3. Если в магазине есть два или три символа, извлечем их из него и попытаемся применить продукционное правило.
Обратим внимание, что применяя продукционное правило, меняем порядок символов, извлечённых из магазина ---
располагая их именно так как они шли в исходной строке (учитывая свёртку).
Полученный нетерминал S вернем в магазин mss. 

\begin{code}
use2symbols :: [Char] -> Maybe [Char]
use2symbols (m1:m2:mss)    = prodrule [m2,m1] `justadd2list` mss
use2symbols _              = Nothing

use3symbols :: [Char] -> Maybe [Char]
use3symbols (m1:m2:m3:mss) = prodrule [m3,m2,m1] `justadd2list` mss
use3symbols _              = Nothing
\end{code}

Если продукцию применить не можем (выставляем флаг Nothing), переходим к следующему шагу.

4. Если в шаге 3 мы не смогли применить продукции, переходим к шагу 5.
Если на шаге 3 мы смогли применить продукцию, то вновь возвращаемся к началу шага 3.

\begin{code}
step :: (String,String) -> (String,String)
step ([],mss) | (isNothing res) = ([],mss) 
              | otherwise       = step ([],(fromJust res))
                   where res :: Maybe String
                         res = (use2symbols mss `mplus` use3symbols mss)
step (ss,mss) = let
  t = (ss,(use2symbols mss `mplus` use3symbols mss)) `mmplus` (transfer (ss,mss)) in step t
\end{code}

5. Кончились ли элементы во входном списке? Если да, то смотрим результаты парсинга:
получился единственный нетерминал S --- значит, все распозналось, если осталось что-то еще,
то не распозналось.. Если элементы во входном списке еще остались, то переходим к шагу 1.

Ниже применяем полученные функции для создания парсера parser.

\begin{code}
parse teststr = if (mss == "S") 
  then teststr ++ " is valid" 
  else teststr ++ " isn't valid" 
     where (_,mss) = step (teststr,[])
\end{code}

Проверяем результат
parse "()(())"
parse "()("