DocTales : WIP

Document.fs

module Document.Core

type Emphasis = | Regular | Medium | Strong
type TextPart = { Text:string; Emphasis:Emphasis; Style:string option }
                with static member Regular(text) = { Text=text; Emphasis=Regular; Style=None }
                     static member Medium(text) = { Text=text; Emphasis=Medium; Style=None }
                     static member Strong(text) = { Text=text; Emphasis=Strong; Style=None }

type Text = Text of TextPart list
            with static member Regular(text) = Text([TextPart.Regular(text)])
                 static member Medium(text) = Text([TextPart.Medium(text)])
                 static member Strong(text) = Text([TextPart.Strong(text)])
                 static member Block(text) = Text.Regular(text) |> Block
                 static member List(items) = items |> (List.map Text.Regular) |> List

and DocPart =
    | TitledSections of TitledSection list
    | TitledSection of TitledSection
    | Block of Text
    | List of Text list
    | Table of Style:string option * Rows: Row list
    | Section of Section

and TitledSection = { Title: string; Section: Section }

and Row = { Cells: Cell list; Style: string option }
          with static member FromCells(cells) = { Cells = cells; Style = None }
               static member FromCells(cells, style) = { Cells = cells; Style = Some(style) }

and Cell = { Parts: DocPart list; RowSpan: int; ColSpan: int; IsHeader: bool }
           with static member New = { Parts = []; RowSpan = 1; ColSpan = 1; IsHeader = false }
                static member Text(text:string) = Cell.Text(Text.Regular(text))
                static member Text(text:Text) = { Parts = [ Block(text) ]; RowSpan = 1; ColSpan = 1; IsHeader = false }
                static member Header(text:string) = Cell.Header(Text.Regular(text))
                static member Header(text:Text) = { Parts = [ Block(text) ]; RowSpan = 1; ColSpan = 1; IsHeader = true }

and Section = { Parts: DocPart list; BreakBefore: bool; Style: string option }
              with static member FromParts(parts) = { Parts = parts; BreakBefore = false; Style = None }

[<AutoOpen>]
module Tools =
    let withPageBreak section = { section with BreakBefore = true }
    let titled title section = { Title = title; Section = section }

HtmlRenderer.fs

module Document.HtmlRenderer

open Document.Core

let rec toHtml (docPart:DocPart): string seq =
    let toHtmlRow (row:Row) =
        seq {
            yield sprintf "<tr%s>" (match row.Style with | None -> "" | Some(style) -> " class=" + style)
            for cell in row.Cells do
                let tag = if cell.IsHeader then "th" else "td"
                yield sprintf "<%s colspan=\"%d\" rowspan=\"%d\">" tag cell.ColSpan cell.RowSpan
                yield! cell.Parts |> Seq.collect toHtml
                yield sprintf "</%s>" tag
            yield "</tr>" }

    let toHtmlSection parentTag titledSection =
        seq {
            yield sprintf "<%s%s>" parentTag (if titledSection.Section.BreakBefore then " class=\"page-break\"" else "")
            yield sprintf "<span class=\"title\">%s</span>" titledSection.Title
            yield "<div>"
            yield! titledSection.Section.Parts |> Seq.collect toHtml
            yield "</div>"
            yield sprintf "</%s>" parentTag
        }

    let getClass emphasis style =
        match emphasis, style with
        | Regular, None -> ""
        | Medium, None -> " class=\"em-medium\""
        | Strong, None -> " class=\"em-strong\""
        | Regular, Some style -> sprintf " class=\"%s\"" style
        | Medium, Some style -> sprintf " class=\"em-medium %s\"" style
        | Strong, Some style -> sprintf " class=\"em-strong %s\"" style

    let toHtmlTextParts parentTag text =
        seq {
            match text with
            | Text([singlePart]) when singlePart.Style = None ->
                yield sprintf "<%s%s>" parentTag (getClass (singlePart.Emphasis) None)
                yield singlePart.Text
                yield sprintf "</%s>" parentTag
            | Text(parts) ->
                yield sprintf "<%s>" parentTag
                yield! parts |> Seq.map (fun p -> sprintf "<span%s>%s</span>" (getClass (p.Emphasis) (p.Style)) p.Text)
                yield sprintf "</%s>" parentTag
        }

    seq {
        match docPart with
        | TitledSections(sections) ->
            yield "<ol>"
            for section in sections do
                yield! toHtmlSection "li" section
            yield "</ol>"
        | TitledSection(section) ->
            yield! toHtmlSection "div" section
        | Table(style, rows) ->
            yield match style with Some(s) -> sprintf "<table class=\"%s\">" s | None -> "<table>"
            for row in rows do
                yield! toHtmlRow row
            yield "</table>"
        | Block(b) -> yield! b |> toHtmlTextParts "p"
        | List(lis) ->
            yield "<ul>"
            yield! lis |> Seq.collect (toHtmlTextParts "li")
            yield "</ul>"
        | Section(section) ->
            yield
                match section.Style, section.BreakBefore with
                | Some(s), true -> sprintf "<div class=\"%s page-break\">" s
                | Some(s), false -> sprintf "<div class=\"%s\">" s
                | None, true -> "<div class=\"page-break\">"
                | None, false -> "<div>"
            yield! section.Parts |> Seq.collect toHtml
            yield "</div>"
    }