Mercurial > gui
changeset 16:2e397d373289
Add RemotePager.
| author | Karn Kallio <kkallio@eka> |
|---|---|
| date | Thu, 18 Aug 2011 12:53:17 -0430 |
| parents | 8300d5f0dc19 |
| children | 2947170fcfd6 |
| files | examples/remotePager.ur examples/remotePager.urp examples/remotePager.urs lib.urp remotePager.ur remotePager.urs |
| diffstat | 6 files changed, 287 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/remotePager.ur Thu Aug 18 12:53:17 2011 -0430 @@ -0,0 +1,30 @@ +fun getPage pg = + return {Content = <xml><h2>This is page {[pg]}.</h2></xml>, + Available = 44} + +structure Pager = RemotePager.Make(struct + type errorMarker = {} + type pageGroup = {} + val initPage = fn _ => getPage 0 + val getPage = fn _ pg => + tm <- now; + if mod (toSeconds tm) 5 = 0 then + return (RemotePager.Bad ()) + else + p <- getPage pg; + return (RemotePager.Good p) + end) + +fun main () = + + pager <- Pager.create (); + + return + <xml> + <head><title>RemotePager Example</title></head> + <body onload={Pager.onError pager (fn _ => alert "bad found")}> + <h1>RemotePager Example</h1> + <div>{Pager.panelXml pager}</div> + <div>{Pager.ctlXml pager}</div> + </body> + </xml>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/remotePager.urp Thu Aug 18 12:53:17 2011 -0430 @@ -0,0 +1,7 @@ +path META=../../meta +library ../ +rewrite url RemotePager/* +allow url http://* +prefix http://localhost:8080/ + +remotePager
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/remotePager.urs Thu Aug 18 12:53:17 2011 -0430 @@ -0,0 +1,1 @@ +val main : {} -> transaction page
--- a/lib.urp Sun Aug 07 14:38:52 2011 -0400 +++ b/lib.urp Thu Aug 18 12:53:17 2011 -0430 @@ -15,3 +15,4 @@ popupNav navigation clock +remotePager
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/remotePager.ur Thu Aug 18 12:53:17 2011 -0430 @@ -0,0 +1,170 @@ +type formatCtl = {Width : int, + RangeCtl : $(mapU (transaction {} -> xbody) [First, Back, Next, Last]), + PageCtl : $(mapU (int -> transaction {} -> xbody) [Unsel, Sel]), + WrapPageCtl : xbody -> xbody, + Wrap : $(mapU xbody [First, Back, Pages, Next, Last]) -> xbody} + +style firstCtl +style backCtl +style nextCtl +style lastCtl +style curPage +style rangeCtl + +fun defaultFormatLbl {First = fLbl, Back = bLbl, Next = nLbl, Last = lLbl} = + let + fun mkLink c txt = fn a => <xml><li onclick={a} class={c}><a class={c} onclick={return ()}>{[txt]}</a></li></xml> + in + {Width = 5, + RangeCtl = {First = mkLink firstCtl fLbl, + Back = mkLink backCtl bLbl, + Next = mkLink nextCtl nLbl, + Last = mkLink lastCtl lLbl}, + PageCtl = {Unsel = fn n a => <xml><li onclick={a}><a onclick={return ()}>{[n + 1]}</a></li></xml>, + Sel = fn n a => <xml><li onclick={a} class={curPage}><a class={curPage} onclick={return ()}>{[n + 1]}</a></li></xml>}, + WrapPageCtl = fn x => x, + Wrap = fn {First = f, Back = b, Pages = p, Next = n, Last = l} => <xml><ul class={rangeCtl}>{f}{b}{p}{n}{l}</ul></xml>} + end + +val defaultFormat = defaultFormatLbl {First = "<<", Back = "<", Next = ">", Last = ">>"} + +type pageData = {Content : xbody, Available : int} +datatype response err = Good of pageData | Bad of err + +functor Make(M : sig + type errorMarker + type pageGroup + val initPage : pageGroup -> transaction pageData + val getPage : pageGroup -> int -> transaction (response errorMarker) + end) : sig + type t + val createFmt : formatCtl -> M.pageGroup -> transaction t + val create : M.pageGroup -> transaction t + val onError : t -> (M.errorMarker -> transaction {}) -> transaction {} + val panelXml : t -> xbody + val ctlXml : t -> xbody +end = struct + open M + + type t = {FormatCtl : formatCtl, + PageGroup : pageGroup, + OnError : source (errorMarker -> transaction {}), + CurrentPage : source int, + RangeStart : source int, + Available : source int, + Content : source xbody} + + fun max x y = if x > y then x else y + fun min x y = if x < y then x else y + + fun loadPage t pg = + ret <- rpc (getPage t.PageGroup pg); + + case ret of + Good pageData => + let + val lst = max 0 (pageData.Available - 1) + val rgtRange = max 0 (pageData.Available - t.FormatCtl.Width) + in + if pg > lst then + loadPage t lst + else + rg <- get t.RangeStart; + (if rg > rgtRange then + set t.RangeStart rgtRange + else + return ()); + set t.CurrentPage pg; + set t.Content pageData.Content; + set t.Available pageData.Available + end + | Bad e => + handler <- get t.OnError; + handler e + + fun createFmt fmt grp = + pg <- source 0; + rg <- source 0; + + pageData <- initPage grp; + + av <- source (pageData.Available); + c <- source (pageData.Content); + + e <- source (fn _ => return {}); + + return {FormatCtl = fmt, + PageGroup = grp, + OnError = e, + CurrentPage = pg, + RangeStart = rg, + Available = av, + Content = c} + + val create = createFmt defaultFormat + + fun onError t f = + set t.OnError f + + fun panelXml t = + <xml> + <dyn signal={signal t.Content}/> + </xml> + + fun ctlXml t = + let + val fmt = t.FormatCtl + val width = fmt.Width + + fun floor pg = + return (max 0 pg) + + fun lastPage () = + av <- get t.Available; + floor (av - 1) + + fun rightRange () = + lst <- lastPage (); + floor (lst - width + 1) + + fun ceil pg = + rgt <- rightRange (); + return (min rgt pg) + + fun setRange startPage = + startPage <- ceil startPage; + startPage <- floor startPage; + set t.RangeStart startPage + + fun printLinks start cur available = + let + val wanted = start + width - 1 + val have = max 0 (available - 1) + val lst = min wanted have + + fun printLinks' n (acc : xbody) = + if n > lst then + acc + else + printLinks' (n + 1) + <xml>{acc}{(if n = cur then + fmt.PageCtl.Sel + else + fmt.PageCtl.Unsel) n (loadPage t n)}</xml> + in + printLinks' start <xml/> + end + in + fmt.Wrap {First = fmt.RangeCtl.First (setRange 0), + Back = fmt.RangeCtl.Back (pg <- get t.RangeStart; setRange (pg - 1)), + Pages = fmt.WrapPageCtl + <xml> + <dyn signal={start <- signal t.RangeStart; + av <- signal t.Available; + cur <- signal t.CurrentPage; + return (printLinks start cur av)}/> + </xml>, + Next = fmt.RangeCtl.Next (pg <- get t.RangeStart; setRange (pg + 1)), + Last = fmt.RangeCtl.Last (pg <- rightRange (); setRange pg)} + end +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/remotePager.urs Thu Aug 18 12:53:17 2011 -0430 @@ -0,0 +1,78 @@ +(* How to format the control section. *) +type formatCtl = {Width : int, + (* Maximum number of page options to show. *) + RangeCtl : $(mapU (transaction {} -> xbody) [First, Back, Next, Last]), + (* A group of four functions taking transactions which will be used to return + * an element having that transaction as onclick. Used to format the buttons + * controlling the selection of page options. First starts the options at the + * first page, Back starts the options one page lower, Next one page higher + * and Last has them finish at the final page. *) + PageCtl : $(mapU (int -> transaction {} -> xbody) [Unsel, Sel]), + (* Used to generate the xml bearing the page selection onclick action. Sel + * is used for the currently shown page and Unsel for the others. *) + WrapPageCtl : xbody -> xbody, + (* The sequence of page selection controls will be wrapped by this. *) + Wrap : $(mapU xbody [First, Back, Pages, Next, Last]) -> xbody + (* Draws the control by placing the individual controls in the holes. *)} + +style firstCtl +style backCtl +style nextCtl +style lastCtl +style curPage +style rangeCtl +(* Default styles. *) + +val defaultFormat : formatCtl +(* A reasonable default format. *) + +val defaultFormatLbl : $(mapU string [First, Back, Next, Last]) -> formatCtl +(* A default format with configurable labels on the page range controls. *) + +type pageData = {Content : xbody, Available : int} +(* Content and page count needed from the RPC. *) + +datatype response err = Good of pageData | Bad of err +(* The RPC gives us either page information or an error code. *) + +functor Make(M : sig + type errorMarker + (* Classifies the possible error conditions returned by the rpc call. *) + + type pageGroup + (* Classifies families of pages. *) + + val initPage : pageGroup -> transaction pageData + (* Used once to initialize the first page and page count. + * The RPC mechanism is not used and no error is possible. *) + + val getPage : pageGroup -> int -> transaction (response errorMarker) + (* RPC giving the content of a requested page as well as the count + * of how many pages are available. The first page should be given + * an index of 0. *) + end) : sig + + type t + (* The type of remote pagers. A remote pager is a + * widget which shows a list of available "pages" of + * information. The user can click on a page they want + * displayed, which is then fetched from the server via + * a RPC. *) + + val createFmt : formatCtl -> M.pageGroup -> transaction t + (* Get a remote pager widget with a custom format showing pages from the selected group. *) + + val create : M.pageGroup -> transaction t + (* Get a remote pager widget with the default format (partly customizable via CSS). *) + + val onError : t -> (M.errorMarker -> transaction {}) -> transaction {} + (* Allows setting an error handler. In case of an rpc error code return, this will + * be called with the received error marker. If not set, the default error handler + * does nothing. *) + + val panelXml : t -> xbody + (* Returns a piece of xml holding the contents of the current page. *) + + val ctlXml : t -> xbody + (* Returns a xml widget representing the clickable page selection controls. *) +end