[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