Html Dsl

Html.fs

module Html =
  type Tag(name:string) =
    let mutable _safeContent = false
    member val className = "" with get, set
    member val content = "" with get, set
    // For ease of use, support children in both list and resize array
    member val childrenL : Tag list = [] with get, set
    member val childrenR = ResizeArray<Tag>() with get, set
    member this.name with get() = name
    member this.isSafeContent with get() = _safeContent
    member this.safeContent
      with set(value) = this.content <- value; _safeContent <- true

    override this.ToString() =
      let rec render (sb:Text.StringBuilder) (tag:Tag) (indent:int) =
        let inline ws (s:string) = sb.Append(s) |> ignore
        let inline wc (c:Char) = sb.Append(c) |> ignore

        ws (String.replicate indent " ")
        wc '<'
        ws tag.name
        if tag.className.Length > 0 then
          ws " class=\""
          ws tag.className
          wc '"'
        wc '>'  

        if tag.content.Length > 0 then
          let content = if tag.isSafeContent then tag.content else Web.HttpUtility.HtmlEncode(tag.content)
          ws content

        for c in tag.childrenL do render sb c (indent + 4)
        for c in tag.childrenR do render sb c (indent + 4)

        ws "</"
        ws tag.name
        wc '>'
      let sb = Text.StringBuilder()
      render sb this 0
      sb.ToString()

  // Tag construction helpers

  let tagClassSafe (tagName:string) (className:string) (safeContent:string) =
    Tag(tagName, className = className, safeContent = safeContent)

  let tagClassUnsafe (tagName:string) (className:string) (content: string) =
    Tag(tagName, className = className, content = content)

  let tagClassChildren (tagName:string) (className:string) (children: Tag list) =
    Tag(tagName, className = className, childrenL = children)

  let tagChildren (tagName:string) (children: Tag list) =
    Tag(tagName, childrenL = children)

  let divClassChildren = tagClassChildren "div"
  let divClassSafe = tagClassSafe "div"
  let divClass = tagClassUnsafe "div"

Usage.fs

open Utils.Html 

let renderPermissions() =
  let root = Tag("div", className="permissions-root")

  for KeyValue(table, (defaultPerm, rolePerms)) in permissions do
    let title = Tag("h1", safeContent = table)
    let td = tagClassUnsafe "td" ""    
    let th = tagClassUnsafe "th" ""
    let table = 
      tagClassChildren "table" "table"
        [tagChildren "thead"
           [tagChildren "tr"
             [th "Role"
              th "Reading"
              th "Updating"
              th "Inserting"
              th "Deleting"]]]

    let pcond =  function | Condition.Inherit -> "" | x -> sprintf "%A" x

    let pconds =
      function
      | (Condition.Inherit as cond, _) -> pcond cond
      | (cond, ColumnSelection.ALL) -> pcond cond
      | (cond, cols) -> sprintf "%s(%A)" (pcond cond) cols

    let addPerm (role:string) (perm:Permission) =
      (tagChildren "tbody"
        [tagClassChildren "tr" "" 
          [td role
           td (pconds perm.reading)
           td (pconds perm.updating)
           td (pconds perm.inserting)
           td (pcond perm.deleting)]])
      |> table.childrenR.Add

    addPerm "Default" defaultPerm
    for KeyValue(role, perm) in rolePerms do addPerm (sprintf "%A" role) perm

    let div = divClassChildren "permission-entry" [title; table]
    root.childrenR.Add(div)
  
  root.ToString()