Игрушечный веб - 1

Как-то странно получается. Я активно не люблю стрелки (имеются в виду, естественно, хаскельные Arrows), и, тем не менее, постоянно их сочиняю, как правило, применительно к вебу. На этот раз речь пойдёт о задачке, которую несколько невнятно сформулировал mr_aleph в своём посте #rocket web-science.
Речь о том, чтобы сымитировать десктопное приложение в вебе, не прибегая к помощи джаваскрипта и не храня ничего на сервере. Для простоты мы ограничимся выводом текста и кнопками - в роли которых у нас будут выступать ссылки. Задумка в том, чтобы клик по ссылке работал как нажатие кнопки, меняя состояние виджетов на странице (т.е., в основном, меняя отображаемые надписи). При этом, состояние виджетов, не имеющих отношения к этой кнопке, должно, естественно, сохраняться. Отсюда вытекает, что в каждой ссылке должно быть прописано состояние всех виджетов вообще, которые есть на странице - и в то же время мы хотим писать виджеты, содержащие ссылки, не зная заранее, что на странице будет ещё.
Итак, в бой. Задача прикручивания всего этого к какому-нибудь веб-серверу (например, happstack-у) мне представляется чисто технической, а потому неинтересной. Мы будем использовать упрощённый формат: выводить по одной надписи или ссылке на строчку и вручную запускать нашу "страницу", передавая ей в качестве параметра ту "ссылку", на которой мы, вроде как, кликнули. Ссылки будем выводит так: caption <URL>.
Первый модуль, который я использую, появляется по одной-единственной причине: мне нужно, чтобы страница, в которую мы специально не запихивали никакое состояние (как бывает, когда страница вызывается в первый раз), всё-таки какое-то состояние имела. Я подумывал использовать в качестве состояния каждого виджета Maybe что-то-там, но решил, что проще будет использовать специальный класс. Уже потом я сообразил, что Maybe ... - это СВОБОДНЫЕ алгебры над монадой Maybe, а подобный класс - это ВСЕ алгебры над этой же монадой:

> module Pointed where
> class Pointed l where point :: l
> instance Pointed () where point = ()
> instance Pointed (Maybe a) where point = Nothing
> instance (Pointed a, Pointed b) => Pointed (a, b) where point = (point, point)

Тут, в общем-то, всё понятно. Кстати говоря, в языке моей мечты класс Pointed будет единственным классом вообще.
Второй модуль необходим для сериализации/десериализации состояний. Собственно, никто не мешает использовать стандартную комбинацию (Show a, Read a), но при этом получаются настолько огромные выражения, что на них просто неприятно смотреть.
Здесь мы используем довольно стандартный трюк, слегка напоминающий "разностные списки". То, что нам нужно - это функции a -> String и String -> a. Подобные штуки, увы, плохо комбинируются; поэтому, мы соорудим ПРЕОБРАЗОВАТЕЛИ таких функций - и вот они уже комбинируются хорошо: всё, что нам нужно - это, в общем-то, сериализовать пару, умея сериализовать её компоненты; это делается банальной композицией соответствующих преобразователей:

> module Serialize where
> class Serialize a where
>     serialize :: (b -> String) -> (a, b) -> String
>     deserialize :: (String -> b) -> String -> (a, b)

Коль скоро мы хотим, всё-таки, именно сериализации и десериализации - нам понадобятся соответствующие функции

> writeSer :: Serialize a => a -> String
> writeSer x = serialize (const "") (x, ())
> readSer :: Serialize a => String -> a
> readSer s = let (x, ()) = deserialize (const ()) s in x

Ключевая идея - в том, что мы худо-бедно знаем, как сериализовать (), а, значит, можем (при помощи нашего преобразователя) сериализовать пару, где () будет на втором месте - а это то же самое, что сериализовать первый компонент пары.
Кстати, это наше знание, как сериализовать () надо бы оформить:

> instance Serialize () where
>     serialize f (_, y) = f y
>     deserialize f s = ((), f s)

Далее, обещанная сериализация пары:

> instance (Serialize a, Serialize b) => Serialize (a, b) where
>     serialize f ((x, y), z) = serialize (serialize f) (x, (y, z))
>     deserialize f s = let (x, (y, z)) = deserialize (deserialize f) s in ((x, y), z)

Ну и ещё несколько инстансов, шоб було; они все довольно очевидные:

> instance Serialize Integer where
>     serialize f (n, y) = show n ++ "," ++ f y
>     deserialize f s = let (s1, ',':s2) = break (',' ==) s in (read s1, f s2)
> instance Serialize a => Serialize (Maybe a) where
>     serialize f (Nothing, y) = 'N' : f y
>     serialize f (Just x, y) = 'Y' : serialize f (x, y)
>     deserialize f ('N':s) = (Nothing, f s)
>     deserialize f ('Y':s) = let (x, y) = deserialize f s in (Just x, y)
> instance Serialize Bool where
>     serialize f (True, x) = 'y' : f x
>     serialize f (False, x) = 'n' : f x
>     deserialize f ('y':s) = (True, f s)
>     deserialize f ('n':s) = (False, f s)

OK, далее начинается интересное. Допустим, у нас уже есть некая стрелка, и мы хотим добавить в неё состояние, причём достаточно произвольного типа. При комбинировании стрелок соответствующие состояния тоже должны комбинироваться. Стрелка имеет некоторое состояние и в процессе вычисления ИЗМЕНЯЕТ его.

> {-# LANGUAGE ExistentialQuantification, Arrows #-}

Коли наше состояние должно быть различных типов - не обойтись без forall; коли мы говорим о стрелках - не обойтись без специального синтаксиса для них.

> import Control.Arrow
> import qualified Control.Category as C
> import Pointed
> import Serialize

Первые два импорта стандартны для программ, определяющих свои стрелки; последние два - подключаем два предыдущих модуля, так как состояние у нас обязательно будет а) сериализуемое, и б) имеющее значение по умолчанию. Модуль Control.Category подключается с префиксом, так как в нём есть функция id, конфликтящая со стандартной.

> data NetState a input output = forall local. (Serialize local, Pointed local) => NetState (a (input, local) (output, local))

И вот он, самый смак. Определение почти очевидное; вместо двух наших классов можно использовать любой класс X, лишь бы для него был определён instance (X a, X b) => X (a, b). Однако, как только оно написано, определения стрелочных операций получаются моментально:

> instance Arrow a => C.Category (NetState a) where
>     id = arr id
>     NetState ns2 . NetState ns1 = NetState ns
>         where ns =
>                   proc (input, (local1, local2)) ->
>                       do (middle, l1) <- ns1 -< (input, local1)
>                          (output, l2) <- ns2 -< (middle, local2)
>                          returnA -< (output, (l1, l2))
> instance Arrow a => Arrow (NetState a) where
>     arr f = NetState $ proc (input, _) -> returnA -< (f input, ())
>     first (NetState ns) = NetState ns'
>         where ns' =
>                   proc ((input, z), local) ->
>                       do (output, l) <- ns -< (input, local)
>                          returnA -< ((output, z), l)
> instance ArrowChoice a => ArrowChoice (NetState a) where
>     left (NetState ns) = NetState ns'
>         where ns' =
>                   proc (inputOrZ, local) ->
>                       case inputOrZ of
>                         Left input ->
>                             do (output, l) <- ns -< (input, local)
>                                returnA -< (Left output, l)
>                         Right z -> returnA -< (Right z, local)
> instance ArrowLoop a => ArrowLoop (NetState a) where
>     loop (NetState ns) = NetState ns'
>         where ns' =
>                   proc (input, local) ->
>                       do rec ((output, z), l) <- ns -< ((input, z), local)
>                          returnA -< (output, l)

Здесь почти не о чем говорить. Состояние композиции двух стрелок есть пара из состояния первой и состояния второй из них. Обратите внимание, что для instance C.Category (NetState a) недостаточно C.Category a, требуется Arrow.

Продолжение следует.