style active
style last

datatype navItem = NavItem of string * url

fun name (NavItem (text, url)) = text

datatype navBar m = NavBar of (list navItem) * (list navItem)
(* First list is items before the active item, second list is items at and after the active one.
 * If the second list is non-empty its head is the active item.  Parameter mode is to avoid
 * double reverses coming from calling printingNavBar. *)

type build = unit
type print = unit

class mode t = navBar t -> xbody

(* The case of special treatment for the last one seems common in themes. *)
fun mapXLast [a ::: Type] [ctx ::: {Unit}] (f : a -> bool -> xml ctx [] []) (ls : list a) : (xml ctx [] []) =
    let
        fun mapXLast' ls =
            case ls of
                [] => <xml/>
              | x :: [] => <xml>{f x True}</xml>
              | x :: ls => <xml>{f x False}{mapXLast' ls}</xml>
    in
        mapXLast' ls
    end

fun navItemToXml css (NavItem (text, url)) =
    case css of
        None => <xml><a href={url} title={text}>{[text]}</a></xml>
      | Some cl => <xml><a class={cl} href={url} title={text}>{[text]}</a></xml>

fun navBarToXml' (NavBar (before, after)) =
    let
        fun navListToXml checkForLast =
            mapXLast (fn navItem lst =>
                         let
                             val linkXml = navItemToXml None navItem
                         in
                             if checkForLast && lst then
                                 <xml><li class={last}>{linkXml}</li></xml>
                             else
                                 <xml><li>{linkXml}</li></xml>
                         end)
    in
        case after of
            [] => <xml>{navListToXml True before}</xml>
          | act :: tl =>
            <xml>
              {navListToXml False before}
              {case tl of
                   [] => <xml><li class={last}>{navItemToXml (Some active) act}</li></xml>
                 | _ =>
                   <xml>
                     <li>{navItemToXml (Some active) act}</li>
                     {navListToXml True tl}
                   </xml>}
            </xml>
    end

fun printingNavBar (NavBar (before, after)) =
    NavBar (List.rev before, List.rev after)

fun navBarToXml [t ::: Type] (m : mode t) = m

fun navToXml_build (n : navBar build) : xbody =
    navBarToXml' (printingNavBar n)

fun navToXml_print (n: navBar print) : xbody =
    navBarToXml' n

val emptyNavBar = NavBar ([], [])

fun mkNavItem text url =
    NavItem (text, url)

fun navAdd navItem navBar =
    case navBar of
        NavBar (before, []) => NavBar (navItem :: before, [])
      | NavBar (before, after) => NavBar (before, navItem :: after)

fun navAddActive navItem navBar =
    case navBar of
        NavBar (before, []) => NavBar (before, navItem :: [])
      | NavBar (before, after) => NavBar (List.append after before, navItem :: [])