[Haskell-cafe] Unsafe IO and Wash
Tomasz Zielonka
tomasz.zielonka at gmail.com
Wed Feb 16 10:04:04 EST 2005
On Wed, Feb 16, 2005 at 08:27:31AM -0600, John Goerzen wrote:
> > You do know that the current version of WASH rebuilds the continuation
> > by repeating all the previous steps, don't you? Until WASH can keep the
>
> Yes. What I don't understand is why. If I have a submit button, and it
> is passing one value to the next function, and that value is from an
> entry form on the screen, why would I care about all the previous state?
> That's my confusion. It seems unnecessary.
That's the simplest way to rebuild the state of the process if you can't
leave anything on the server (like a process or a continuation).
> Yeah, that's a neat feature. I'm using it some places, too. It's
> probably true that I don't understand fully how to exploit it yet. (I wish
> that I could return something other than () from a screen too.)
> I just want a way to pass only what I need. Passing lots of stuff is
> going to make my applications painful for modem users, which
> unfortnuately make up a large part of the user base.
You can, you just have to use the continuation passing style. For
example, if you want screen to return a value of type LotsOfStuff, you
instead create a function that takes the continuation as parameter:
screen :: (LotsOfStuff -> CGI ()) -> CGI ()
screen cont = do
ask $ do
...
submit ... f ...
where
f (F4 a b c d) = ...
let stuff = ...
cont stuff
Of course, you have to call it appropriately:
otherScreen = do
..
screen (\stuff -> ...)
See my contributed WASH example. It's not on the WASH website yet,
probably because it requires some changes in the library. It should
be easy to make it work with the current WASH release - just import
CGI instead of GuaranteedCGI, and fix the types involving WithHTML.
I can do this, if you're interested. You can also test the app at
this address
http://212.186.92.25/~tomek/TreeEdit.cgi
It should be available from 08:00 to 24:00 CET.
I would like to hear what you think - both about the code and the app.
Best regards
Tomasz
--
Szukamy programisty C++ i Haskell'a: http://tinyurl.com/5mw4e
-------------- next part --------------
module Main (module Main) where
import GuaranteedCGI hiding (map, a, i, button, submit)
import qualified GuaranteedCGI as CGI
import Prelude hiding (head)
import Monad (when)
import Maybe (maybeToList)
main :: IO ()
main = run start
startTree :: Tree String
startTree =
Node "/"
[ Node "etc"
[ Node "X11" []
]
, Node "bin" []
, Node "dev" []
, Node "lib" []
, Node "usr"
[ Node "bin" []
, Node "lib" []
, Node "local"
[ Node "bin" []
, Node "lib" []
]
, Node "share" []
, Node "X11R6" []
]
, Node "home"
[ Node "tom" []
, Node "bart" []
]
]
data STATE =
STATE
{ sTree :: Tree (Bool, String)
, sClipboard :: [Tree (Bool, String)]
}
start :: CGI ()
start = do
mainScreen $
STATE
{ sTree = fmap ((,) True) startTree
, sClipboard = []
}
mainScreen :: STATE -> CGI ()
mainScreen state =
ask $ do
myPage "Tree Editor" $ do
table $ do
uaBORDER "1"
uaCELLSPACING "0"
tbody $ do
tr $ do
td $ do
myButton "COLLAPSE ALL" $ do
mainScreen $
state { sTree = fmap (\(_, x) -> (True, x)) tree }
td $ do
myButton "EXPAND ALL" $ do
mainScreen $
state { sTree = fmap (\(_, x) -> (False, x)) tree }
td $ do
myButton "CLEAR CLIPBOARD" $ do
mainScreen $
state { sClipboard = [] }
text $ "Clipboard contains " ++ show (length clipboard) ++ " trees"
table $ do
uaBORDER "1"
uaCELLSPACING "0"
tbody $ do
treeRows
where
STATE { sTree = tree, sClipboard = clipboard } = state
zipWithApply = zipTreesWith ($)
treeRows =
(flip foldTree)
(fmap (const (,,,)) tree
`zipWithApply` toTrees tree
`zipWithApply` toContext tree
`zipWithApply` toMaybeContext tree
`zipWithApply` toDepths tree)
(\( subTree@(Node (isCollapsed, name) children)
, context
, contextM
, depth
)
chs -> do
let hasChildren = not (null children)
hasCollapsedChildren = isCollapsed && hasChildren
remove clipbF =
case contextM Nothing of
Nothing -> ask $ do
myPage "NO TREE" $ do
text "You have removed the whole tree"
Just tree' -> do
mainScreen $
state
{ sTree = tree'
, sClipboard = clipbF clipboard
}
tr $ do
td $ do
myButton "DELETE" $ do
remove id
td $ do
myButton "CUT" $ do
remove (++ [subTree])
td $ do
myButton "PASTE" $ do
mainScreen $
state
{ sTree = context (Node (False, name) (children ++ clipboard))
, sClipboard = []
}
td $ do
myButton "ADD" $ do
addScreen
(mainScreen state) $
\newName ->
mainScreen $
state
{ sTree =
context $
Node (False, name)
(children ++ [Node (False, newName) []])
}
td $ do
myButton "EDIT" $ do
editScreen
(mainScreen state)
name $
\newName ->
mainScreen $
state
{ sTree =
context $ Node (isCollapsed, newName) children
}
td $ do
let setColl c =
state { sTree = context (Node (c, name) children) }
when hasChildren $ do
if isCollapsed
then myButton "EXPAND" $ do
mainScreen $ setColl False
else myButton "COLLAPSE" $ do
mainScreen $ setColl True
td $ do
uaALIGN "left"
uaSTYLE $ "padding-left: " ++ show depth ++ "cm"
let t () = text name
if hasCollapsedChildren
then strong (t ())
else (t ())
when (not isCollapsed) $ sequence_ chs
)
----------------------------------------------------------------------
addScreen :: CGI () -> (String -> CGI ()) -> CGI ()
addScreen back add = do
ask $ do
myPage "New node" $ do
text "Name: "
i <- textInputField (uaSIZE "30")
mySubmit
(F1 i)
(\(F1 i') -> add (value i'))
(uaVALUE "ADD")
br empty
myButton "CANCEL" back
----------------------------------------------------------------------
editScreen :: CGI () -> String -> (String -> CGI ()) -> CGI ()
editScreen back name change = do
ask $ do
myPage "Edit node" $ do
text "Name: "
i <- textInputField $ do
uaSIZE "30"
uaVALUE name
mySubmit
(F1 i)
(\(F1 i') -> change (value i'))
(uaVALUE "CHANGE")
br empty
myButton "CANCEL" back
----------------------------------------------------------------------
-- The Tree datatype
--
-- In most new haskell environments it's distributed in Data.Tree module,
-- however, some older GHC version had a Show instance unsuitable for WASH.
-- It's irrelevant for this example, but we would be in trouble if we wanted
-- to load the initial tree from a database or file.
data Tree a = Node a [Tree a] deriving (Show, Read)
instance Functor Tree where
fmap f (Node x ts) = Node (f x) (map (fmap f) ts)
zipTreesWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c
zipTreesWith f (Node x xts) (Node y yts)
= Node (f x y) (zipWith (zipTreesWith f) xts yts)
toContextGeneric :: (Tree a -> b) -> (b -> [Tree a]) -> Tree a -> Tree (b -> b)
toContextGeneric wrap1 wrap2 t = toCtx id t
where
toCtx ctx (Node elt children) =
Node
ctx
[ toCtx (\x -> let (before, _ : after) = splitAt i children
in ctx (wrap1 (Node elt (before ++ wrap2 x ++ after))))
c
| (i,c) <- zip [0..] children ]
toContext :: Tree a -> Tree (Tree a -> Tree a)
toContext = toContextGeneric id return
toListContext :: Tree a -> Tree ([Tree a] -> [Tree a])
toListContext = toContextGeneric return id
toMaybeContext :: Tree a -> Tree (Maybe (Tree a) -> Maybe (Tree a))
toMaybeContext = toContextGeneric Just maybeToList
toDepths :: Tree a -> Tree Int
toDepths t = foldTree f t 0
where
f _ cs d = Node d (map ($ d+1) cs)
toTrees :: Tree a -> Tree (Tree a)
toTrees n@(Node _ cs) = Node n (map toTrees cs)
foldTree :: (a -> [b] -> b) -> Tree a -> b
foldTree f (Node a cs) = f a (map (foldTree f) cs)
----------------------------------------------------------------------
-- Some CGI helpers
myPage :: String -> WithHTML FORM CGI () -> WithHTML DOCUMENT CGI ()
myPage screenName c = do
html $ do
head $ do
title $ text screenName
meta $ do
uaNAME "author"
uaCONTENT "Tomasz Zielonka <tomasz.zielonka at gmail.com>"
body $ do
rawtext $ unlines $
[ "<style type=\"text/css\"><!--"
, ".myButton {"
, " border-width: 0;"
, " background-color: transparent;"
, " font-weight: bold;"
, " color: blue;"
, "}"
, "--></style>"
]
makeForm $ do
c
myButton :: AdmitChildINPUT y => String -> CGI () -> WithHTML y CGI ()
myButton txt action = do
submit0 action $ do
uaVALUE txt
uaCLASS "myButton"
mySubmit :: (AdmitChildINPUT y, InputHandle h) =>
h INVALID -> (h VALID -> CGI ()) -> WithHTML INPUT CGI () -> WithHTML y CGI ()
mySubmit inputs action elts = do
CGI.submit inputs action (uaCLASS "myButton" >> elts)
More information about the Haskell-Cafe
mailing list