Posts (page 2)

А мне всего-то хотелось сделать композицию трансформеров...

> {-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeOperators #-}
> module MonadM where
> import Control.Monad

Допустим, мы хотим применить к некоторой монаде несколько трансформеров. Причём, мы заранее не знаем, к какой именно монаде - но знаем, какие трансформеры. Ну, например, пусть это будут

> newtype StateT s m x = StateT {runStateT :: s -> m (s, x)}
> instance Monad m => Monad (StateT s m) where
>     return x = StateT $ \s -> return (s, x)
>     st >>= f = StateT $ \s -> runStateT st s >>= \(s', x) -> runStateT (f x) s'

и

> newtype ReaderT r m x = ReaderT {runReaderT :: r -> m x}
> instance Monad m => Monad (ReaderT r m) where
>     return x = ReaderT $ \r -> return x
>     rt >>= f = ReaderT $ \r -> runReaderT rt r >>= \x -> runReaderT (f x) r

Конечно, нет никакой проблемы написать трансформер-композицию.

newtype SRT s r m x = SRT (ReaderT r (StateT s m) x)

Далее, можно точно также объявить

instance Monad m => Monad (SRT s r m)

и жить припеваючи.

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

Попробуем это сделать. Для начала, всё-таки, объявим класс для трансформеров, чтобы не всухомятку обсуждать:

class Trans t where
    lift :: m x -> t m x

И сделаем простенькую композицию:

newtype (Trans t1, Trans t2) => (t2 :. t1) m x = Compose {runCompose :: t2 (t1 m) x} deriving Monad

Контекст здесь нужен, на самом деле, только для того, чтобы все kind-ы были правильными. Позднее мы его несколько ослабим.

Далее, нужно, чтобы это был снова трансформер:

instance (Trans t1, Trans t2) => Trans (t2 :. t1) where
    lift = Compose . lift . lift

Пока что, всё работает прекрасно. Давайте же сделаем два наших трансформера инстансами соответствующего класса, зарелизим библиотеку на Hackage и пойдём пить кофе с бубликами.

instance Trans (StateT s) where
    lift mx = StateT smx
        where smx s =
                  do x <- mx
                     return (s, x)

Упс. Получили ругань:

MonadM.lhs:54:23:
    Could not deduce (Monad m) from the context ()
      arising from a do statement
                   at MonadM.lhs:54:23-29
    Possible fix:
      add (Monad m) to the context of the type signature for `lift'
    In a stmt of a 'do' expression: x <- mx
    In the expression:
        do x <- mx
           return (s, x)
    In the definition of `smx':
        smx s = do x <- mx
                   return (s, x)
Failed, modules loaded: none.

Фикус в том, что для того, чтобы написать нашу функцию lift, нам нужно использовать, что аргумент засунут именно в монаду, а не во что-то ещё. Действительно нужно, это не фантазия какая-то.

Попробуем пофиксить, изменив сигнатуру lift.

class Trans t where
    lift :: Monad m => m x -> t m x

Опять облом.

MonadM.lhs:49:23:
    Could not deduce (Monad (t1 m)) from the context (Monad m)
      arising from a use of `lift'
                   at MonadM.lhs:49:23-26
    Possible fix:
      add (Monad (t1 m)) to the context of the type signature for `lift'
      or add an instance declaration for (Monad (t1 m))
    In the first argument of `(.)', namely `lift'
    In the second argument of `(.)', namely `lift . lift'
    In the expression: Compose . lift . lift
Failed, modules loaded: none.

Теперь проблема в том, что из instance Monad m и instance Trans t не следует instance Monad (t m). Практически это всегда так - по крайней мере, это так для двух трансформеров, которые мы определили в самом начале. Но у нас нет способа убедить компилятор, что это и будет всегда так.

Подход, принятый в шаблонах C++ заключается в том, чтобы забить на контекст вообще и ругаться, если он не выполняется в каждом конкретном случае. Думаю, в языке, принимающем статическую типизацию близко к сердцу, подобный вариант не имеет права на существование.

В Языке Моей Мечты(tm) я бы написал так:

class Trans t where
    lift :: Monad m => m x -> t m x
    instance Monad m => Monad (t m)

После чего я перенёс бы instance Monad m => Monad (StateT s m) внутрь instance Trans (StateT s) и всё заработало бы. Увы, Язык Моей Мечты(tm) пока лишён важной утилиты, а именно, компилятора. Нет, интерпретатора тоже нет. Так что, этот способ тоже не сработает.

Попробуем иначе. Что нам нужно, так это добавить в класс Trans какую-то функцию, которая сообщит компилятору, что происходит именно преобразование монад, а не чего-то ещё. Иначе говоря, нам нужно работать с классом Monad как с типом данных.

Попробуем это сделать.

Что вообще означает, что некоторый тип T является монадой? Это означает, что для данного типа определены несколько операций. Как учит нас теория категорий, где есть алгебраические операции (или похожие на них), стоит искать... монаду. Да-да, монаду. Правда, так как наши типы имеют не тот kind, эта монада также будет монадой на другой категории. Следовательно, имеет смысл для начала определить эту категорию:

> type (m :-> n) = forall x. m x -> n x

Вот они - морфизмы нашей новой категории.

Далее, опять же, теория категорий учит, что новую монаду нужно определять так: объекту p ставится в соответствие нечто вроде "множества всех выражений, составленных при помощи заданных операций из элементов p". То есть, в нашем случае подошло бы что-то в таком духе:

data MonadM p x where
    Term :: p x -> MonadM p x
    Return :: x -> MonadM p x
    Bind :: MonadM p x -> (x -> MonadM p y) -> MonadM p y

Я, однако, предпочитаю более простой и универсальный подход. Сейчас я определю тот же тип, но по-другому. Вуаля:

> newtype MonadM p x = MonadM {bindM :: Monad m => (p :-> m) -> m x}

Это и правда то же самое. Теперь, MonadM имеет kind

*MonadM> :k MonadM
MonadM :: (* -> *) -> * -> *

и, следовательно, похож на монаду на категории типов kind-a  (* -> *). Не хватает только функций return и (>>=) для полного счастья. Сейчас мы их определим.

Начнём с return. Обычно, эта функция имеет типx -> m x (так она определена в классе Monad). У нас, следовательно, тип будет

> term :: p :-> MonadM p

Такую функцию написать несложно, и делается это, по существу, единственным образом:

> term px = MonadM $ \hom -> hom px

Далее, оператор (>>=). Он у нас, по сути, уже есть. Это функция bindM. Её тип поначалу не кажется похожим на то, что нам нужно, но только потому, что у нас не хватает ещё одного важного элемента:

> instance Monad (MonadM p) where
>     return x = MonadM $ \hom -> return x
>     mpx >>= f = MonadM $ \hom -> bindM mpx hom >>= \x -> bindM (f x) hom

В этом определении мы просто говорим, что правая часть, по существу, совпадает с левой, только вокруг тех штук, которые имеют тип MonadM p x добавляется некий line noise в виде bindM и hom.

Теперь мы видим, что функция bindM имеет тип, который, во всяком случае, не хуже, чем то, что нам нужно:

*MonadM> :set -XTypeOperators -XRankNTypes
*MonadM> :t bindM :: MonadM p x -> (p :-> MonadM p) -> MonadM p x
bindM :: MonadM p x -> (p :-> MonadM p) -> MonadM p x
  :: MonadM p x -> (p :-> MonadM p) -> MonadM p x

Хорошо. Далее, то, чему не учат в Haskell-школах: конкретный объект с нужными нам операциями является ни чем иным как алгеброй над подобной монадой. В нашем случае это значит, что каждая монада является алгеброй над  MonadM. Более конкретно, для каждой монады есть отображение

alg :: Monad m => MonadM m :-> m

Именно, оно пишется так:

alg (MonadM h) = h id

В данном случае, id имеет тип m :-> m.

Как же это поможет нам решить нашу проблему? А вот как: по сути дела, указать для некоторого типа отображение alg и определить для этого же типа instance Monad - одно и то же. !. Я определю специальный тип:

> newtype Inst m = Inst {getInst :: MonadM m :-> m}

и навешу конструктор на alg следующим образом:

> alg :: Monad m => Inst m
> alg = Inst $ \mmx -> bindM mmx id

Далее, идеология происходящего следующая. Если нам нужно что-то сделать с типом m, для чего требуется instance Monad, а у нас вместо него только значение inst :: Inst m, то мы проделываем всё необходимое, используя вместо m тип MonadM m (который всегда является монадой - определение только что было), а потом переносим это на тип m, используя при этом отображения term :: m :-> MonadM m и getInst inst :: MonadM m :-> m.

Для того, чтобы этот перенос осуществить, нам потребуется такой класс:

class Iso t where iso :: (m :-> n) -> (n :-> m) -> (t m :-> t n)

На самом деле, мне неизвестны трансформеры монад, которые не были бы ковариантны по этим монадам, так что можно сократить сигнатуру:

> class Iso t where iso :: (m :-> n) -> (t m :-> t n)

instance Iso обычно пишется несложно и бойлерплейт получится весьма небольшой.

В частности, например, легко написать такое:

> infixl 1 `bindM`
> instance Iso MonadM where iso hom mmx = mmx `bindM` term . hom

Заметьте, я здесь, фактически, воспроизвёл определение функции liftM:

liftM f mx = mx >>= return . f

Класс трансформеров теперь определяется так:

> class Iso t => Trans t where
>     lift :: Monad m => m x -> t m x
>     liftInst :: Inst m -> Inst (t m)

Обратите внимание на изменившийся контекст.

В частности, теперь можно сделать трансформером композицию трансформеров.

> newtype (Iso t1, Iso t2) => (t2 :. t1) m x = Compose {runCompose :: t2 (t1 m) x} deriving Monad
> infixr 9 :.

Здесь я изменил контекст с Trans на Iso, чтобы следующий инстанс выглядел более вменяемо:

> instance (Iso t1, Iso t2) => Iso (t2 :. t1) where iso hom ttmx = Compose $ iso (iso hom) $ runCompose ttmx

Ну и, как я и обещал, композиция трансформеров - трансформер:

> instance (Trans t1, Trans t2) => Trans (t2 :. t1) where

Нам нужно пройти от m x к (t2 :. t1) m x

Обычно мы пошли бы по маршруту m x --> t1 m x --> t2 (t1 m) x --> (t2 :. t1) m x.

Увы, если первый и последний шаги особых проблем не представляют, то второй шаг, увы, невозможен, так как t1 m не является монадой (по крайней мере, мы не можем убедить компилятор, что является). Однако, у нас есть значение alg :: Inst m, и, следовательно, также и значение liftInst alg :: Inst (t1 m). В соответствии с общей идеологией, мы сделаем второй шаг несколько более длинным, а именно, пройдём по маршруту t1 m x --> MonadM (t1 m) x --> t2 (MonadM (t1 m)) x --> t2 (t1 m) x.

Делаем:

    lift = Compose . step2 . lift
        where step2 = iso (getInst $ liftInst alg) . lift . term

или, коль скоро принцип ясен,

>     lift = Compose . iso (getInst $ liftInst alg) . lift . term. lift
>     liftInst = isoInst . liftInst . liftInst
>         where isoInst :: (Iso t1, Iso t2) => Inst (t2 (t1 m)) -> Inst ((t2 :. t1) m)
>               isoInst inst = Inst $ \mmx -> Compose $ getInst inst $ iso runCompose mmx

Пока всё не слишком (надеюсь) сложно. Но сумеем ли мы сделать наши StateT и ReaderT инстансами класса Trans? Ну, первая часть проблем не вызывает:

> instance Iso (StateT s) where iso hom smx = StateT $ hom . runStateT smx
> instance Trans (StateT s) where
>     lift mx = StateT smx
>         where smx s =
>                   do x <- mx
>                      return (s, x)

Здесь почти ничего не изменилось. Далее, нам нужно от Inst m перейти к Inst (StateT s m).

Если бы m было монадой, то всё было бы не просто, а очень просто: достаточно было бы использовать значение alg, поскольку instance Monad m => Monad (StateT s m) у нас уже есть. Увы, m не обязательно является монадой, однако мы начинаем со значения типа Inst m! В соответствии с общей идеологией, мы пройдём по маршруту MonadM (StateT s m) --> MonadM (StateT s (MonadM m)) --> StateT s (MonadM m) --> StateT s m следующим образом:

    liftInst inst = Inst $ iso (getInst inst) . getInst alg . iso (iso term)

У меня лично сразу проситься вынести alg в дополнительный параметр и написать так:

>     liftInst = makeLiftInst alg
> makeLiftInst :: Iso t => Inst (t (MonadM m)) -> Inst m -> Inst (t m)
> makeLiftInst alg' inst = Inst $ iso (getInst inst) . getInst alg' . iso (iso term)

Тип для функции makeLiftInst, признаюсь, написал не я, а компилятор. Ну, пусть будет.

Аналогично пишется инстанс для ReaderT:

> instance Iso (ReaderT r) where iso hom rmx = ReaderT $ hom . runReaderT rmx
> instance Trans (ReaderT r) where
>     lift mx = ReaderT $ const mx
>     liftInst = makeLiftInst alg

Обратите внимание, что объявление функции liftInst совершенно одинаковое, что для StateT, что для ReaderT. Мы можем написать ещё несколько трансформеров, но везде будет то же самое. Нельзя ли его написать, например, как дефолтную реализацию в самом классе? Попробовав, получаем

MonadM.lhs:392:30:
    Could not deduce (Monad (t (MonadM m))) from the context ()
      arising from a use of `alg'
                   at MonadM.lhs:392:30-32
    Possible fix:
      add (Monad (t (MonadM m))) to the context of
        the type signature for `liftInst'
      or add an instance declaration for (Monad (t (MonadM m)))
    In the first argument of `makeLiftInst', namely `alg'
    In the expression: makeLiftInst alg
    In the definition of `liftInst': liftInst = makeLiftInst alg
Failed, modules loaded: none.

Увы, так не получится. Причина здесь в том, что мы для каждого конкретного T определяем instance Monad m => Monad (T m) отдельно, и строчка liftInst = makeLiftInst alg как бы является обещанием, что такой инстанс определён где-то в другом месте; компилятор же это обещание тщательно проверит.

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

> newtype Monad m => (t :$ m) x = Apply {runApply :: t m x}
> infixr 0 :$
> instance (Trans t, Monad m) => Monad (t :$ m) where
>     return x = Apply $ getInst (liftInst alg) $ return x
>     tmx >>= f = Apply $ getInst (liftInst alg) $ term (runApply tmx) >>= \x -> term (runApply $ f x)

Фикус в том, что мы дописываем к значениям tmx :: (t :$ x) x мусор вида term (runApply tmx), а обратно приходим при помощи Apply . getInst (liftInst alg). В остальном же, мы просто в правой части повторяем левую.

Теперь можно писать, например, (StateT Int :. ReaderT String :$ Maybe) Char и это будет примерно (с точностью до newtype-ов) то же самое, что и (StateT Int :$ ReaderT String :$ Maybe) Char или State Int (ReaderT String (Maybe Char)).

Если кто-то вдруг захочет написать собственный трансформер  MyCoolTransformer - нет проблем, пусть сделает три вещи:

1)

instance Monad m => Monad (MyCoolTransformer m)

Если этого не сделать, то непонятно, почему вообще речь идёт о трансформерах монад.

2)

lift :: m x -> MyCoolTransformer m x

Это - то, для чего трансформеры монад действительно нужны.

3) Заклинание liftInst = makeLiftInst alg, которое пишется без участия мозга. Как видим, весь бойлерплейт сведён к одной строчке - что можно записывать как победу.

Маленькое замечание: здесь мы почти не пользовались тем, что речь идёт именно о монадах. Точно то же самое можно написать про трансформеры, например, стрелок. Понадобиться только а) изменить понятие морфизма, так как стрелки имеют другой kind, б) заменить два инстанса на полностью аналогичные, один для нашей "монады" (которая, если мы заменим монады на стрелки,.. останется монадой), и один для оператора применения трансформера к монадестрелке.

я пытался освоить Лисп. И там была одна вещь, которую моё подсознательное всякий раз отвергало.

Я в принципе не мог понять, как это - результатом конструкций типа progn является результат последнего выражения. А куда же деваются результаты остальных???

Нет, разумом я понимаю: они производят некий сайд-эффект. Проблема в том, что то, что должно возвращать значение, и то, что по смыслу никакого значения возвращать не должно, а нужно только для сайд-эффекта, глазом не различается никак. Поэтому принять эту концепцию сердцем я не мог. Мне всё время казалось, что если результат этой штуковины не нужен, то её можно будет просто выкинуть, она нафиг не нужна.

Даже в Паскале сразу очевидно - здесь у нас ":=" и интересует нас возвращаемое значение; а здесь у нас никакого ":=" нет, и интересует нас сайд-эффект.

И поэтому основной частью do-синтаксиса в Хаскеле я считаю синтаксическую разницу между действием и связыванием переменной:

do action
   ...

или

do var <- expression
   ...

Я таки сделал этот чёртов ArrowLoop!

Не буду бить на несколько модулей - на винчестере у меня сейчас всё уже сильно не так, сделано довольно много изменений, так что я просто напишу, как делать ArrowLoop - используя при этом три модуля из первого постинга на эту тему.

Для начала - шапка:

> {-# LANGUAGE Arrows #-}
> module Loop where
> import Control.Arrow
> import qualified Control.Category as C
> import Control.Monad
> import Control.Monad.Fix
> import Data.Maybe
> import Data.Monoid
> import Pointed
> import Serialize
> import NetState

Здесь нет ничего особо интересного. Единственное что - я импортирую Control.Monad.Fix, потому что в одном месте мне будет удобно явно написать функцию fix.

Тип Signal из предыдущего постинга претерпел некоторые изменения - в частности, он перестал быть монадой и стал функтором:

> newtype Signal link html a = Signal ((a -> link) -> html)
> instance Functor (Signal link html) where fmap f (Signal s) = Signal $ \linkMaker -> s $ linkMaker . f

Кроме того, он является АДДИТИВНЫМ функтором - и я слегка офигел, обнаружив, что в стандартной библиотеке такого класса нет:

> class Functor f => Additive f where
>     azero :: f a
>     aplus :: f a -> f a -> f a
> instance Monoid html => Additive (Signal link html) where
>     azero = Signal $ const mempty
>     Signal s1 `aplus` Signal s2 = Signal $ \linkMaker -> s1 linkMaker `mappend` s2 linkMaker

Старый тип Signal восстанавливается из нового, а его instance Monad - из instance Additive нового:

> data SignalMonad f a = SignalMonad a (f a)
> instance Additive f => Monad (SignalMonad f) where
>     return x = SignalMonad x azero
>     SignalMonad x fx >>= h = let SignalMonad y fy = h x in SignalMonad y $ fmap (\x -> let SignalMonad y _ = h x in y) fx `aplus` fy

Теперь старый тип Signal становится SignalMonad (Signal). Получился симпатичный рефакторинг.

Однако, нам не нужен старый тип Signal. Нам нужен его вариант, имеющий не только выход, но и вход, причём (!) часть его входа может зависеть от выхода. Именно наличие такой зависимости делает возможным создание instance ArrowLoop.

Делаем:

> data SignalArrow f input output = SignalArrow {pure :: input -> output, effect :: (output -> input) -> f output}

От Kleisli(SignalMonad Signal) это отличается только тем, что вместо input в одном месте стоит (output -> input). Вот она и зависимость.

Далее - довольно стандартные инстансы. Основная идея композиции таких стрелок - если мы знаем, как возвращать сигнал из конца в начало, а нам нужно вернуть его из СЕРЕДИНЫ в начало, то мы сначала протаскиваем его в конец, а потом возвращаем в начало известным способом. Аналогично, если нужно вернуть сигнал из конца в середину - мы возвращаем его в начало, а затем протаскиваем в середину.

> instance Additive f => C.Category (SignalArrow f) where
>     id = arr id
>     sl2 . sl1 = SignalArrow {pure = pure sl2 . pure sl1, effect = e}
>         where e reaction = fmap (pure sl2) (effect sl1 $ reaction . pure sl2) `aplus` effect sl2 (pure sl1 . reaction)

Функция first требует некоторого допинывания ногами, но, как только нам удаётся удовлетворить тайпчекер - всё работает.

> instance Additive f => Arrow (SignalArrow f) where
>     arr f = SignalArrow {pure = f, effect = const azero}
>     first sl = SignalArrow {pure = first (pure sl), effect = e}
>         where e reaction = 
>                   let findZ output = let (input, z) = reaction (output, z) in (output, z)
>                   in fmap findZ $ effect sl $ fst . reaction . findZ

Теперь обещанный ArrowLoop. Мы специально постарались сделать всё так, чтобы можно было его написать - ничего удивительного, что он таки написался, причём легко.

> instance Additive f => ArrowLoop (SignalArrow f) where
>     loop sl = SignalArrow {pure = \input -> let (output, z) = pure sl (input, z) in output, effect = e}
>         where e reaction = fmap fst $ effect sl $ first reaction

Наконец, самое забавное. ArrowChoice.

Фишка в том, что ArrowChoice даёт нам возможность, в зависимости от приходящих сигналов, рендерить разные части виджета. При этом мы не хотим, чтобы сигнал, пройдя через виджет и вернувшись назад по какому-то циклу, поменял выбор той части, которая должна рендериться. Смена отображаемого куска должна происходить только между загрузками страницы, но не во время. Гарантировать это статически мы не можем никак. Поэтому я сознательно допускаю возможность, что в этом месте вычисление упадёт с ошибкой. Оно не должно падать - и не будет, если страница написана нормально.

> instance Additive f => ArrowChoice (SignalArrow f) where
>     left sl = SignalArrow {pure = left $ pure sl, effect = e}
>         where e reaction =
>                   case fix $ reaction . left (pure sl) of
>                     Left _ -> fmap Left $ effect sl $ \output -> let Left input = reaction $ Left output in input
>                     Right _ -> azero

Собираем всё это вместе, не забыв, как обычно, добавить состояние:

> type Link = String
> type Html = String
> type Widget = NetState (SignalArrow (Signal Link Html))

На вход всей страницы всегда подаётся (), а локальное состояние зачитывается из пришедшего от пользователя URL. Выход страницы игнорируется - поэтому, обратной связи, фактически, не будет - точнее, вместо функции она будет константой:

> renderPage :: Widget () output -> Maybe Link -> Html
> renderPage (NetState sl) ml =
>     let Signal render = effect sl $ const ((), maybe point readSer ml)
>     in render $ \(_, local) -> writeSer local

Теперь нужны label, link и state - почти такие же, как в прошлом постинге.

Для начала - label. Выход label - всегда (), поэтому обратная связь не может быть ничем, кроме константы; нас интересует, следовательно, её единственное значение:

> label :: Widget String ()
> label = NetState $ SignalArrow {pure = const ((),()), effect = \reaction -> Signal $ const $ fst (reaction ((),())) ++ "\n"}

Вход link - всегда (), поэтому обратная связь может быть только const (). Поэтому, мы её вообще проигнорируем.

> link :: String -> Widget () Bool
> link caption = NetState $ SignalArrow {pure = const (False, ()), effect = const $ Signal $ \linkMaker -> caption ++ " <" ++ linkMaker (True, ()) ++ ">\n"}

Ну и, наконец, state. State не отображается никак, а потому не интересуется обратной связью.

> state :: Serialize local => local -> Widget (local -> local) local
> state initial = NetState $ SignalArrow {pure = p, effect = const azero}
>     where p (f, ml) = let l = fromMaybe initial ml in (l, Just $ f l)

Готово. Попробуем, чтобы убедиться, что старые примеры продолжают работать:

> test1 =
>     proc () ->
>         do clicked <- link "+" -< ()
>            number <- state (0 :: Integer) -< if clicked then (+ 1) else id
>            label -< show number
>            link "refresh" -< ()

Загружаем в GHCi:

*Loop> putStr $ renderPage test1 $ Nothing
+ <Y1,>
0
refresh <Y0,>
*Loop> putStr $ renderPage test1 $ Just "Y1,"
+ <Y2,>
1
refresh <Y1,>

Теперь убедимся, что новые фокусы тоже работают:

> test5 =
>     proc () ->
>         do rec {label -< show number;
>                 number <- state (0 :: Integer) -< if clicked then (+ 1) else id;
>                 clicked <- link "+1" -< ()}
>            link "refresh" -< ()

В этом примере всё почти также, как и в test1 - только ссылка, изменяющая счётчик, расположена ПОСЛЕ самого счётчика. Это было невозможно со старой реализацией, зато с новой:

*Loop> putStr $ renderPage test5 $ Nothing
0
+1 <Y1,>
refresh <Y0,>
*Loop> putStr $ renderPage test5 $ Just "Y1,"
1
+1 <Y2,>
refresh <Y1,>

Работает, однако. Чувствую, пора из игрушечного фреймворка делать полноразмерный.

Последнее замечание: виджет-хамелеон, который упоминался в прошлый раз, по-прежнему не делается. И я не уверен, что его удастся сделать более-менее разумным образом.

Довольно банальная завязка - американка, вышедшая замуж за англичанина, приезжает в его дом и знакомится с его семьёй, явно её не одобряющей - превратилась в классно сыгранный, классно поставленный фильм с классным саундтреком. Рекомендую - Easy Virtue, или "Лёгкое поведение". Кстати, в переводе, вроде бы, идёт в наших кинотеатрах прямо сейчас.

Продолжение; начало здесь
Теперь - основное: собственно, виджеты.

> {-# LANGUAGE Arrows #-}
> module HTML where
> import Control.Arrow

Этот модуль реально подключается только ради стрелок Клейсли (как мы помним, каждая монада даёт стрелку - вот, это они и есть).

> import Data.Maybe
> import Data.Monoid

Ну, куда же без моноидов...

> import NetState
> import Pointed
> import Serialize

Три предыдущих модуля. Пригодится.
Для начала мы соорудим монаду, как первое приближение к виджетам. Наш "недовиджет" будет посылать некоторый сигнал; кроме того, он будет содержать произвольное количество ссылок. Клик по каждой ссылке меняет состояния, потенциально, всех остальных виджетов на странице. Но как именно он их меняет? Только при помощи изменения выходного сигнала данного виджета - это единственный способ для нашего виджета повлиять на других. Поэтому, каждая ссылка а) определяет новый выходной сигнал, и б) содержит новые состояния всех виджетов на странице, причём б) определяется по а). Вот эту самую функцию, определяющую б) (а точнее, сразу URL, который надо запихнуть в ссылку) по а), мы передадим "недовиджету" как параметр:

> data Signal link html a = Signal a ((a -> link) -> html)

Теперь надо превратить это дело в монаду. Виджет "return" не будет отображаться вообще, он будет лишь выдавать сигнал на выход; для отображения связки двух виджетов мы сначала отображаем один из них, затем второй:

> instance Monoid html => Monad (Signal link html) where
>     return x = Signal x $ const mempty
>     Signal x render1 >>= f =
>         let Signal y render2 = f x
>             render linkMaker = render1 (\x -> let Signal y _ = f x in linkMaker y) `mappend` render2 linkMaker
>         in Signal y render

Наши URL-ы будут просто строками; выходной HTML - тоже всего лишь строкой:

> type Html = String
> type Link = String

Теперь мы хотим добавить к нашим виджетам состояние. У нас уже есть способ это сделать, но он работает со стрелками, а не с монадами. Вот тут и нужны стрелки Клейсли:

> type Widget = NetState (Kleisli (Signal Link Html))

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

> renderPage :: Widget () output -> Maybe Link -> Html
> renderPage (NetState (Kleisli widget)) ml =
>     let Signal _ render = widget ((), maybe point readSer ml)
>     in render $ \(_, local) -> writeSer local

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

> label :: Widget String ()
> label = NetState $ Kleisli $ \(text, _) -> Signal ((),()) $ const $ text ++ "\n"
> link :: String -> Widget () Bool
> link caption = NetState $ Kleisli $ const $ Signal (False, ()) $ \linkMaker -> caption ++ " <" ++ linkMaker (True, ()) ++ ">\n"
> state :: (Serialize local) => local -> Widget (local -> local) local
> state initial = NetState $ Kleisli $ \(f, mx) -> let x = fromMaybe initial mx in Signal (x, Just $ f x) $ const ""

Готово. Теперь можно обозвать это умным словом "фреймворк". Нет, правда, готово.
Проверим. Первый тест - страница, содержащая две ссылки и поле, отображающее число. Нажатие на первую ссылку увеличивает число на 1; нажатие на вторую - рефрешит страницу:

> test1 =
>     proc () ->
>         do clicked <- link "+" -< ()
>            number <- state (0 :: Integer) -< if clicked then (+ 1) else id
>            label -< show number
>            link "refresh" -< ()

Проверяем в GHCi:

*HTML> putStr $ renderPage test1 $ Nothing
+ <Y1,>
0
refresh <Y0,>
*HTML> putStr $ renderPage test1 $ Just "Y1,"
+ <Y2,>
1
refresh <Y1,>
*HTML> putStr $ renderPage test1 $ Just "Y2,"
+ <Y3,>
2
refresh <Y2,>

В первый раз мы подаём на вход Nothing; затем мы каждый раз подаём на вход URL из той ссылки, по которой мы, вроде как, кликнули.
Второй тест - снова две ссылки и число, но на сей раз вторая ссылка уменьшает число на 1:

> test2 =
>     proc () ->
>         do increase <- link "+" -< ()
>            decrease <- link "-" -< ()
>            number <- state (0 :: Integer) -< \n -> n + (if increase then 1 else 0) - (if decrease then 1 else 0)
>            label -< show number

Проверяем:

*HTML> putStr $ renderPage test2 $ Nothing
+ <Y1,>
- <Y-1,>
0
*HTML> putStr $ renderPage test2 $ Just "Y-1,"
+ <Y0,>
- <Y-2,>
-1
*HTML> putStr $ renderPage test2 $ Just "Y-2,"
+ <Y-1,>
- <Y-3,>
-2

Работает.
Третий пример: размещаем на странице ДВА виджета из первого примера. По идее, они должны работать независимо:

> test3 =
>     proc () ->
>         do test2 -< ()
>            test2 -< ()

И тестируем:

*HTML> putStr $ renderPage test3 $ Nothing
+ <Y1,Y0,>
- <Y-1,Y0,>
0
+ <Y0,Y1,>
- <Y0,Y-1,>
0
*HTML> putStr $ renderPage test3 $ Just "Y1,Y0,"
+ <Y2,Y0,>
- <Y0,Y0,>
1
+ <Y1,Y1,>
- <Y1,Y-1,>
0
*HTML> putStr $ renderPage test3 $ Just "Y2,Y0,"
+ <Y3,Y0,>
- <Y1,Y0,>
2
+ <Y2,Y1,>
- <Y2,Y-1,>
0
*HTML> putStr $ renderPage test3 $ Just "Y2,Y1,"
+ <Y3,Y1,>
- <Y1,Y1,>
2
+ <Y2,Y2,>
- <Y2,Y0,>
1
*HTML> putStr $ renderPage test3 $ Just "Y1,Y1,"
+ <Y2,Y1,>
- <Y0,Y1,>
1
+ <Y1,Y2,>
- <Y1,Y0,>
1

И опять работает.
Четвёртый пример: своего рода "визард" с двумя страницами, с кнопкой для переключения. На каждой странице мы разместим виджет из второго примера:

> test4 =
>     proc () ->
>         do switch <- link "switch" -< ()
>            displayFirst <- state True -< if switch then not else id
>            if displayFirst
>               then do label -< "first page"
>                       test2 -< ()
>               else do label -< "second page"
>                       test2 -< ()

GHCi-сессия:

*HTML> putStr $ renderPage test4 $ Nothing
switch <YnY0,N>
first page
+ <YyY1,N>
- <YyY-1,N>
0
*HTML> putStr $ renderPage test4 $ Just "YyY1,N"
switch <YnY1,N>
first page
+ <YyY2,N>
- <YyY0,N>
1
*HTML> putStr $ renderPage test4 $ Just "YnY1,N"
switch <YyY1,Y0,>
second page
+ <YnY1,Y1,>
- <YnY1,Y-1,>
0
*HTML> putStr $ renderPage test4 $ Just "YnY1,Y-1,"
switch <YyY1,Y-1,>
second page
+ <YnY1,Y0,>
- <YnY1,Y-2,>
-1
*HTML> putStr $ renderPage test4 $ Just "YyY1,Y-1,"
switch <YnY1,Y-1,>
first page
+ <YyY2,Y-1,>
- <YyY0,Y-1,>
1

Чего здесь не хватает?
Во-первых, каждый виджет может влиять лишь на те виджеты, которые идут после него. Для влияния "назад" нам понадобился бы instance ArrowLoop Widget - который мы автоматически получили бы, если бы сообразили instance MonadFix Signal. Тогда можно было бы написать, скажем,

> test5 =
>     proc () ->
>         do rec {label -< show number;
>                 number <- state (0 :: Integer) -< if clicked then (+ 1) else id;
>                 clicked <- link "+1" -< ()}
>            returnA -< ()

Увы, с текущей реализацией Signal это, похоже, невозможно.
Другая фишка, которую мне лично очень хотелось бы иметь - это "виджет-хамелеон", который может получить на вход другой виджет и вести себя как он, до тех пор, пока не получит новый виджет, и станет вести себя уже как он. Подобная вещь была в фуджетах; как это счастье реализовать, я лично пока не очень представляю.
На сегодня всё, спасибо за внимание.

Как-то странно получается. Я активно не люблю стрелки (имеются в виду, естественно, хаскельные 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.

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

Продолжается процесс выбора логотипа для Хаскеля. У меня потихоньку закрадываются сомнения в том, что этот процесс является сходящимся.

А вот я сегодня увидел где-то флаг Чехии:

И понял, что это почти наш флаг:

Когда в Haskell-cafe обсуждают теоркат - это нормально. Теперь в рассылке по теоркату начали обсуждать Haskell. И весьма активно, приводя примеры кода.

в хохмагазинах можно купить компас со стрелкой, намагниченной поперёк?

Из комментов к посту про платную/бесплатную медицину на ЛОРе:

> Сервис - ничуть не хуже коммерческого.

Ты пробовал когда-нибудь попадать в больницу? Обычную, бюджетную?

Меня бог пока миловал. Зато некоторых родственников я там посещал (и сопровождал).

Так вот. Сначала, приехав, ты несколько часов лежишь на каталке в приёмном покое. Вокруг тебя толчётся человек двадцать больных с разнообразными неизвестными пока болячками. Медсестёр две-три, и на вопрос "сестра, когда же моя очередь" они злобно огрызаются, ибо заебались уже всем повторять, что не знают. Вполне возможна ситуация, когда кто-нибудь подойдёт и вколет тебе что-нибудь, проигнорировав твои робкие вопросы "а что это" и "от чего это" - лежи потом, и думай, не перепутали ли тебя с другим больным. Каталка неудобная, где сортир - неизвестно, поесть не принесут.

Потом ты попадаешь в палату, где лежат ещё четыре-пять человек. Один из них непрерывно орёт. Не потому, что ему больно, нет. Просто он сумасшедший. Поэтому никто никаких мер, чтобы он не орал, принимать не будет. Если ты можешь ходить, то ещё один сосед будет с частотой раз в пять минут просить тебя позвать сестру, потому как сам он ходить не может. Если ты не можешь ходить, то никто из соседей для тебя сестру не позовёт. А если позовёт - будет хуже, сестра придёт злобная и уставшая от постоянной беготни по больным. Вонища в палате будет стоять страшная, а если ты попытаешься проветрить помещение, на тебя заорут в несколько глоток, что ты хочешь, чтобы они все поумирали от простуды - что, кстати, недалеко от истины.

Поесть ты сможешь; если ты лежачий - тебе принесут. Принесут откровенные помои. Не торопись вставать на ноги - в столовой то же самое. Если у тебя нет родственников, которые готовы каждый день носить тебе еду - твои дела плохи. Именно каждый день, потому что холодильника нет и не будет. Об элементарной вещи типа электрической розетки в палате (хотя бы мобильник зарядить) - не мечтай. И не оставляй мобилу без внимания - в больницах воруют, и много.

Если ты совсем плох и вообще ничего не можешь - больница сделает тебе ещё хуже. Сталкивался со случаем, когда больной, простите, обосрался и лежал в собственном дерьме - он физически был не в состоянии что-то исправить, а сестра подходить не торопилась.

Не думай, что, заплатив медсестре, ты сможешь избавиться хотя бы от одного недостатка из указанных. Платят ВСЕ. Ну, или, по крайней мере, многие. Они физически не в состоянии обеспечить более-менее полноценный уход каждому.

Излишне говорить, что в КОММЕРЧЕСКИХ больницах ничего этого нет. Исключением может стать разве что качество еды - оно и в платных больницах бывает не очень (хотя и получше), но зато холодильник там, как правило, есть.

А теперь учти: если ты вызовешь бесплатную скорую, и она обнаружит, что тебе необходима госпитализация - тебя повезут в бесплатную же больницу. В ту, к которой эта скорая приписана. Если ты вызываешь платную скорую - тебя повезут в ту больницу, в которую ты захочешь сам; если твои предпочтения не столь определённы - врач обзвонит больницы, которые тебе подходят, и выяснит, где есть места.

Miguel