path: root/stdlib/source/library/lux/web/html.lux

... This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
... If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/.

(.require
 [library
  [lux (.except Tag Meta Source comment and template open parameter quote)
   [control
    ["[0]" function]
    ["[0]" maybe (.use "[1]#[0]" functor)]]
   [data
    ["[0]" product]
    ["[0]" text (.only)
     ["%" \\format (.only Format format)]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor mix)]]
    [format
     ["[0]" xml (.only XML)]]]
   [meta
    [macro
     ["[0]" template]]
    [compiler
     [target
      ["[0]" js]]]
    [type
     ["[0]" nominal (.except def)]]]
   [world
    [net (.only URL)]]]]
 [//
  ["[0]" css
   ["[0]" selector]
   ["[0]" style (.only Style)]
   ["[1]/[0]" id]
   ["[1]/[0]" class]]])

(type .public Tag selector.Tag)
(type .public ID css/id.ID)
(type .public Class css/class.Class)

... Attributes for an HTML tag.
(type .public Attributes
  (List [Text Text]))

(def .public empty
  Attributes
  (list))

(type .public Script
  js.Statement)

(type .public Target
  (Variant
   {#Blank}
   {#Parent}
   {#Self}
   {#Top}
   {#Frame Text}))

(def (target value)
  (-> Target Text)
  (when value
    {#Blank} "_blank"
    {#Parent} "_parent"
    {#Self} "_self"
    {#Top} "_top"
    {#Frame name} name))

... Properly formats text to ensure no injection can happen on the HTML.
(def safe
  (-> Text Text)
  (|>> (text.replaced "&" "&")
       (text.replaced "<" "&lt;")
       (text.replaced ">" "&gt;")
       (text.replaced text.double_quote "&quot;")
       (text.replaced "'" "&#x27;")
       (text.replaced "/" "&#x2F;")))

(def attributes
  (-> Attributes Text)
  (|>> (list#each (function (_ [key val])
                    (format " " key "=" text.double_quote (..safe val) text.double_quote)))
       text.together))

(def (open tag attributes)
  (-> Tag Attributes Text)
  (|> attributes
      ..attributes
      (format tag)
      (text.enclosed ["<" ">"])))

(def close
  (-> Tag Text)
  (text.enclosed ["</" ">"]))

(nominal.def .public (HTML brand)
  Text

  (.with_template [<name> <brand>]
    [(nominal.def <brand> Any)
     (type .public <name> (HTML <brand>))]

    [Meta Meta']
    [Head Head']
    [Item Item']
    [Option Option']
    [Input Input']
    [Cell Cell']
    [Header Header']
    [Row Row']
    [Column Column']
    [Parameter Parameter']
    [Body Body']
    [Document Document']
    )

  (.with_template [<super> <super_raw> <sub>+]
    [(nominal.def (<super_raw> brand) Any)
     (type .public <super> (HTML (<super_raw> Any)))

     (`` (.with_template [<sub> <sub_raw>]
           [(nominal.def <sub_raw> Any)
            (type .public <sub> (HTML (<super_raw> <sub_raw>)))]

           (,, (template.spliced <sub>+))))]

    [Element Element'
     [[Content Content']
      [Image Image']]]

    [Media Media'
     [[Source Source']
      [Track Track']]]
    )

  (def .public html
    (-> Document Text)
    (|>> representation))

  (def .public (and pre post)
    (All (_ brand) (-> (HTML brand) (HTML brand) (HTML brand)))
    (abstraction (format (representation pre) (representation post))))

  (def .public (comment content node)
    (All (_ brand) (-> Text (HTML brand) (HTML brand)))
    (abstraction
     (format (text.enclosed ["<!--" "-->"] content)
             (representation node))))

  (def (empty_tag name attributes)
    (-> Tag Attributes HTML)
    (abstraction
     (format (..open name attributes)
             (..close name))))

  (def (simple tag attributes)
    (-> Tag Attributes HTML)
    (|> attributes
        (..open tag)
        abstraction))

  (def (tag name attributes content)
    (-> Tag Attributes (HTML Any) HTML)
    (abstraction
     (format (..open name attributes)
             (representation content)
             (..close name))))

  (def (raw tag attributes content)
    (-> Text Attributes Text HTML)
    (abstraction
     (format (..open tag attributes)
             content
             (..close tag))))

  (.with_template [<name> <tag> <brand>]
    [(def .public <name>
       (-> Attributes <brand>)
       (..simple <tag>))]

    [link "link" Meta]
    [meta "meta" Meta]
    [input "input" Input]
    [embedded "embed" Element]
    [column "col" Column]
    [parameter "param" Parameter]
    )

  (def .public (base href target)
    (-> URL (Maybe Target) Meta)
    (let [partial (list ["href" href])
          full (when target
                 {.#Some target}
                 (list.partial ["target" (..target target)] partial)
                 
                 {.#None}
                 partial)]
      (..simple "base" full)))

  (def .public style
    (-> Style Meta)
    (|>> style.inline (..raw "style" (list))))

  (def .public (script attributes inline)
    (-> Attributes (Maybe Script) Meta)
    (|> inline
        (maybe#each js.code)
        (maybe.else "")
        (..raw "script" attributes)))

  (def .public text
    (-> Text Content)
    (|>> ..safe
         abstraction))

  (.with_template [<tag> <alias> <name>]
    [(def .public <name>
       Element
       (..simple <tag> (list)))

     (def .public <alias> <name>)]
    ["br"  br  line_break]
    ["wbr" wbr word_break]
    ["hr"  hr  separator]
    )

  (def .public (image source attributes)
    (-> URL Attributes Image)
    (|> attributes
        {.#Item ["src" source]}
        (..simple "img")))

  (def .public (svg attributes content)
    (-> Attributes XML Element)
    (|> content
        (of xml.codec encoded)
        (..raw "svg" attributes)))

  (type .public Coord
    (Record
     [#horizontal Nat
      #vertical Nat]))

  (def metric_separator ",")
  (def coord_separator ",")

  (def (%coord [horizontal vertical])
    (Format Coord)
    (format (%.nat horizontal) ..metric_separator (%.nat vertical)))
  
  (type .public Rectangle
    (Record
     [#start Coord
      #end Coord]))

  (type .public Circle
    (Record
     [#center Coord
      #radius Nat]))

  (type .public Polygon
    (Record
     [#first Coord
      #second Coord
      #third Coord
      #extra (List Coord)]))

  (def (%rectangle [start end])
    (Format Rectangle)
    (format (%coord start) ..coord_separator (%coord end)))

  (def (%circle [center radius])
    (Format Circle)
    (format (%coord center) ..metric_separator (%.nat radius)))

  (def (%polygon [first second third extra])
    (Format Polygon)
    (|> (list.partial first second third extra)
        (list#each %coord)
        (text.interposed ..coord_separator)))
  
  (type .public Shape
    (Variant
     {#Rectangle Rectangle}
     {#Circle Circle}
     {#Polygon Polygon}))

  (.with_template [<name> <shape> <type> <format>]
    [(def (<name> attributes shape)
       (-> Attributes <type> (HTML Any))
       (..simple "area" (list.partial ["shape" <shape>]
                                      ["coords" (<format> shape)]
                                      attributes)))]

    [rectangle "rect" Rectangle ..%rectangle]
    [circle "circle" Circle ..%circle]
    [polygon "poly" Polygon ..%polygon]
    )
  
  (def (area attributes shape)
    (-> Attributes Shape (HTML Any))
    (when shape
      {#Rectangle rectangle}
      (..rectangle attributes rectangle)
      
      {#Circle circle}
      (..circle attributes circle)
      
      {#Polygon polygon}
      (..polygon attributes polygon)))

  (def .public (each attributes areas for)
    (-> Attributes (List [Attributes Shape]) Image Image)
    (all ..and
         for
         (when (list#each (product.uncurried ..area) areas)
           {.#End}
           (..empty_tag "map" attributes)
           
           {.#Item head tail}
           (..tag "map" attributes
                  (list#mix (function.flipped ..and) head tail)))))

  (.with_template [<name> <tag> <type>]
    [(def .public <name>
       (-> Attributes <type>)
       (..empty_tag <tag>))]

    [canvas "canvas" Element]
    [progress "progress" Element]
    [output "output" Input]
    [source "source" Source]
    [track "track" Track]
    )

  (.with_template [<name> <tag>]
    [(def .public (<name> attributes media on_unsupported)
       (-> Attributes Media (Maybe Content) Element)
       (..tag <tag> attributes
              (|> on_unsupported
                  (maybe.else (..text ""))
                  (..and media))))]

    [audio "audio"]
    [video "video"]
    )

  (def .public (picture attributes sources image)
    (-> Attributes Source Image Element)
    (..tag "picture" attributes (..and sources image)))

  (def .public (anchor href attributes content)
    (-> URL Attributes Element Element)
    (..tag "a" (list.partial ["href" href] attributes) content))

  (def .public label
    (-> ID Input)
    (|>> css/id.id ["for"] list (..empty_tag "label")))

  (.with_template [<name> <container_tag> <description_tag> <type>]
    [(def .public (<name> description attributes content)
       (-> (Maybe Content) Attributes <type> <type>)
       (..tag <container_tag> attributes
              (when description
                {.#Some description}
                (all ..and
                     (..tag <description_tag> (list) description)
                     content)
                
                {.#None}
                content)))]

    [details "details" "summary" Element]
    [field_set "fieldset" "legend" Input]
    [figure "figure" "figcaption" Element]
    )

  (.with_template [<name> <tag> <type>]
    [(def .public (<name> attributes content)
       (-> Attributes (Maybe Content) <type>)
       (|> content
           (maybe.else (..text ""))
           (..tag <tag> attributes)))]

    [text_area "textarea" Input]
    [iframe "iframe" Element]
    )

  (type .public Phrase
    (-> Attributes Content Element))

  (.with_template [<name> <tag>]
    [(def .public <name>
       Phrase
       (..tag <tag>))]

    [abbrebiation "abbr"]
    [block_quote "blockquote"]
    [bold "b"]
    [cite "cite"]
    [code "code"]
    [definition "dfn"]
    [deleted "del"]
    [emphasized "em"]
    [h1 "h1"]
    [h2 "h2"]
    [h3 "h3"]
    [h4 "h4"]
    [h5 "h5"]
    [h6 "h6"]
    [inserted "ins"]
    [italic "i"]
    [keyboard "kbd"]
    [marked "mark"]
    [meter "meter"]
    [pre "pre"]
    [quote "q"]
    [sample "samp"]
    [struck "s"]
    [small "small"]
    [sub "sub"]
    [super "sup"]
    [strong "strong"]
    [time "time"]
    [underlined "u"]
    [variable "var"]
    )

  (def .public incorrect ..struck)

  (def (ruby_pronunciation pronunciation)
    (-> Content (HTML Any))
    (..tag "rt" (list)
           (all ..and
                (..tag "rp" (list) (..text "("))
                pronunciation
                (..tag "rp" (list) (..text ")")))))

  (def .public (ruby attributes content pronunciation)
    (-> Attributes Content Content Element)
    (..tag "ruby" attributes
           (all ..and
                content
                (ruby_pronunciation pronunciation))))

  (type .public Composite
    (-> Attributes Element Element))

  (.with_template [<name> <tag>]
    [(def .public <name>
       Composite
       (..tag <tag>))]

    [article "article"]
    [aside "aside"]
    [dialog "dialog"]
    [div "div"]
    [footer "footer"]
    [header "header"]
    [main "main"]
    [navigation "nav"]
    [paragraph "p"]
    [section "section"]
    [span "span"]
    )

  (.with_template [<tag> <name> <input>]
    [(def <name>
       (-> <input> (HTML Any))
       (..tag <tag> (list)))]

    ["dt" term Content]
    ["dd" description Element]
    )

  (def .public (description_list attributes descriptions)
    (-> Attributes (List [Content Element]) Element)
    (when (list#each (function (_ [term description])
                       (all ..and
                            (..term term)
                            (..description description)))
                     descriptions)
      {.#End}
      (..empty_tag "dl" attributes)
      
      {.#Item head tail}
      (..tag "dl" attributes
             (list#mix (function.flipped ..and) head tail))))

  (def .public p ..paragraph)

  (.with_template [<name> <tag> <input> <output>]
    [(def .public <name>
       (-> Attributes <input> <output>)
       (..tag <tag>))]

    [button "button" Element Input]
    [item "li" Element Item]
    [ordered_list "ol" Item Element]
    [unordered_list "ul" Item Element]
    [option "option" Content Option]
    [option_group "optgroup" Option Option]
    [data_list "datalist" Option Element]
    [select "select" Option Input]
    [address "address" Element Element]
    [form "form" Input Element]
    [data "data" Element Element]
    [object "object" Parameter Element]
    )

  (.with_template [<name> <tag> <input> <output>]
    [(def .public <name>
       (-> <input> <output>)
       (..tag <tag> (list)))]

    [title "title" Content Meta]
    [no_script "noscript" Content Meta]
    [template "template" (HTML Any) (HTML Nothing)]
    [table_header "th" Element Header]
    [table_cell "td" Element Cell]
    [head "head" Meta Head]
    [body "body" Element Body]
    )

  (.with_template [<name> <tag> <input> <output>]
    [(def <name>
       (-> <input> <output>)
       (..tag <tag> (list)))]

    [table_row "tr" (HTML Any) Row]
    [table_head "thead" Row HTML]
    [table_body "tbody" Row HTML]
    [table_foot "tfoot" Row HTML]
    [columns_group "colgroup" Column HTML]
    )

  (def .public (table attributes caption columns headers rows footer)
    (-> Attributes (Maybe Content) (Maybe Column) Header (List Cell) (Maybe Cell) Element)
    (let [head (..table_head (..table_row headers))
          content (when (list#each table_row rows)
                    {.#End}
                    head

                    {.#Item first rest}
                    (..and head
                           (..table_body
                            (list#mix (function.flipped ..and) first rest))))
          content (when footer
                    {.#None}
                    content
                    
                    {.#Some footer}
                    (..and content
                           (..table_foot (..table_row footer))))
          content (when columns
                    {.#None}
                    content
                    
                    {.#Some columns}
                    (..and (..columns_group columns)
                           content))
          content (when caption
                    {.#None}
                    content

                    {.#Some caption}
                    (..and (as HTML caption)
                           content))]
      (..tag "table" attributes
             content)))

  (.with_template [<name> <doc_type>]
    [(def .public <name>
       (-> Head Body Document)
       (let [doc_type <doc_type>]
         (function (_ head body)
           (|> (..tag "html" (list) (..and head body))
               representation
               (format doc_type)
               abstraction))))]

    [html/5    "<!DOCTYPE html>"]
    [html/4_01 (format "<!DOCTYPE HTML PUBLIC " text.double_quote "-//W3C//DTD HTML 4.01//EN" text.double_quote " " text.double_quote "http://www.w3.org/TR/html4/strict.dtd" text.double_quote ">")]
    [xhtml/1_0 (format "<!DOCTYPE html PUBLIC " text.double_quote "-//W3C//DTD XHTML 1.0 Strict//EN" text.double_quote " " text.double_quote "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd" text.double_quote ">")]
    [xhtml/1_1 (format "<!DOCTYPE html PUBLIC " text.double_quote "-//W3C//DTD XHTML 1.1//EN" text.double_quote " " text.double_quote "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd" text.double_quote ">")]
    )
  )