On Vox: Прототяпное

[migmit]

   

{-# LANGUAGE Arrows #-}
module CGIArrow where
import Control.Arrow
data State = State String [State] deriving (Read, Show)
data CGI a b = CGI [(State -> a) -> State -> State] ((State -> a) -> State -> b)
instance Arrow CGI where
    arr f = CGI [] (f .)
    CGI ps f >>> CGI ps' f' = CGI (ps ++ map (. f) ps') (f' . f)
    first (CGI [] f) = CGI [] $ \sac s -> (f (fst . sac) s, snd (sac s))
    first (CGI (p:ps) f) = CGI (p':map t ps) f'
        where t p h (State str (sh:st)) = let State str' st' = p (fst . h) (State str st) in State str' (sh:st')
              p' h s@(State str ss) = t p h $ State str (s:ss)
              f' h (State str (sh:st)) = (f (fst.h) (State str st), snd (h sh))
ask = CGI [\sc s -> State (sc s) []] $ \_ (State str []) -> str
runCGI (CGI ps _) n = (ps !! n) (const ())
graham = proc () -> do foo <- ask -< "What would you like to say?"
                       _ <- ask -< "Click here"
                       ask -< foo
-- These functions help to emulate browser, they don't contribute anything to the server side
answer (State _ ps) str = State str ps
empty = State "" []

Запускаем:
   

*CGIArrow> :load "/Users/MigMit/CGIArrow.hs"
[1 of 1] Compiling CGIArrow         ( /Users/MigMit/CGIArrow.hs, interpreted )
Ok, modules loaded: CGIArrow.
*CGIArrow> runCGI graham 0 empty
State "What would you like to say?" [State "" []]
*CGIArrow> runCGI graham 1 $ answer it "Medvedev kozel"
State "Click here" [State "Medvedev kozel" [State "" []]]
*CGIArrow> runCGI graham 2 $ answer it "Click!"
State "Medvedev kozel" []

И пусть Грэхем удавится со своим Арком.

Originally posted on migmit.vox.com