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