path: root/stdlib/source/library/lux/data/format/xml.lux

(.module:
  [library
   [lux #*
    [abstract
     [monad (#+ do)]
     [equivalence (#+ Equivalence)]
     [codec (#+ Codec)]]
    [control
     [try (#+ Try)]
     ["<>" parser ("#\." monad)
      ["<.>" text (#+ Parser)]]]
    [data
     ["." product]
     ["." name ("#\." equivalence codec)]
     ["." text ("#\." equivalence monoid)]
     [collection
      ["." list ("#\." functor)]
      ["." dictionary (#+ Dictionary)]]]
    [math
     [number
      ["n" nat]
      ["." int]]]]])

(type: .public Tag
  Name)

(type: .public Attribute
  Name)

(type: .public Attrs
  (Dictionary Attribute Text))

(def: .public attributes
  Attrs
  (dictionary.empty name.hash))

(type: .public #rec XML
  (#Text Text)
  (#Node Tag Attrs (List XML)))

(def: namespace_separator
  ":")

(def: xml_standard_escape_char^
  (Parser Text)
  ($_ <>.either
      (<>.after (<text>.this "&lt;") (<>\in "<"))
      (<>.after (<text>.this "&gt;") (<>\in ">"))
      (<>.after (<text>.this "&amp;") (<>\in "&"))
      (<>.after (<text>.this "&apos;") (<>\in "'"))
      (<>.after (<text>.this "&quot;") (<>\in text.double_quote))
      ))

(def: xml_unicode_escape_char^
  (Parser Text)
  (|> (do <>.monad
        [hex? (<>.maybe (<text>.this "x"))
         code (case hex?
                #.None
                (<>.codec int.decimal (<text>.many <text>.decimal))

                (#.Some _)
                (<>.codec int.decimal (<text>.many <text>.hexadecimal)))]
        (in (|> code .nat text.of_char)))
      (<>.before (<text>.this ";"))
      (<>.after (<text>.this "&#"))))

(def: xml_escape_char^
  (Parser Text)
  (<>.either xml_standard_escape_char^
             xml_unicode_escape_char^))

(def: xml_char^
  (Parser Text)
  (<>.either (<text>.none_of ($_ text\compose "<>&" text.double_quote))
             xml_escape_char^))

(def: xml_identifier
  (Parser Text)
  (do <>.monad
    [head (<>.either (<text>.one_of "_")
                     <text>.alpha)
     tail (<text>.some (<>.either (<text>.one_of "_.-")
                                  <text>.alpha_num))]
    (in ($_ text\compose head tail))))

(def: namespaced_symbol^
  (Parser Name)
  (do <>.monad
    [first_part xml_identifier
     ?second_part (<| <>.maybe (<>.after (<text>.this ..namespace_separator)) xml_identifier)]
    (case ?second_part
      #.None
      (in ["" first_part])

      (#.Some second_part)
      (in [first_part second_part]))))

(def: tag^ namespaced_symbol^)
(def: attr_name^ namespaced_symbol^)

(def: spaced^
  (All [a] (-> (Parser a) (Parser a)))
  (let [white_space^ (<>.some <text>.space)]
    (|>> (<>.before white_space^)
         (<>.after white_space^))))

(def: attr_value^
  (Parser Text)
  (let [value^ (<text>.some xml_char^)]
    (<>.either (<text>.enclosed [text.double_quote text.double_quote] value^)
               (<text>.enclosed ["'" "'"] value^))))

(def: attrs^
  (Parser Attrs)
  (<| (\ <>.monad map (dictionary.of_list name.hash))
      <>.some
      (<>.and (..spaced^ attr_name^))
      (<>.after (<text>.this "="))
      (..spaced^ attr_value^)))

(def: (close_tag^ expected)
  (-> Tag (Parser []))
  (do <>.monad
    [actual (|> tag^
                ..spaced^
                (<>.after (<text>.this "/"))
                (<text>.enclosed ["<" ">"]))]
    (<>.assertion ($_ text\compose "Close tag does not match open tag." text.new_line
                      "Expected: " (name\encode expected) text.new_line
                      "  Actual: " (name\encode actual) text.new_line)
                  (name\= expected actual))))

(def: comment^
  (Parser Text)
  (|> (<text>.not (<text>.this "--"))
      <text>.some
      (<text>.enclosed ["<!--" "-->"])
      ..spaced^))

(def: xml_header^
  (Parser Attrs)
  (|> (..spaced^ attrs^)
      (<>.before (<text>.this "?>"))
      (<>.after (<text>.this "<?xml"))
      ..spaced^))

(def: cdata^
  (Parser Text)
  (let [end (<text>.this "]]>")]
    (|> (<text>.some (<text>.not end))
        (<>.after end)
        (<>.after (<text>.this "<![CDATA["))
        ..spaced^)))

(def: text^
  (Parser XML)
  (|> (..spaced^ (<text>.many xml_char^))
      (<>.either cdata^)
      (<>\map (|>> #Text))))

(def: null^
  (Parser Any)
  (<text>.this (text.of_char 0)))

(def: xml^
  (Parser XML)
  (|> (<>.rec
       (function (_ node^)
         (|> (do <>.monad
               [_ (<text>.this "<")
                tag (..spaced^ tag^)
                attrs (..spaced^ attrs^)
                .let [no_children^ ($_ <>.either
                                       (do <>.monad
                                         [_ (<text>.this "/>")]
                                         (in (#Node tag attrs (list))))
                                       (do <>.monad
                                         [_ (<text>.this ">")
                                          _ (<>.some (<>.either <text>.space
                                                                ..comment^))
                                          _ (..close_tag^ tag)]
                                         (in (#Node tag attrs (list)))))
                      with_children^ (do <>.monad
                                       [_ (<text>.this ">")
                                        children (<>.many node^)
                                        _ (..close_tag^ tag)]
                                       (in (#Node tag attrs children)))]]
               ($_ <>.either
                   no_children^
                   with_children^))
             ..spaced^
             (<>.before (<>.some ..comment^))
             (<>.after (<>.some ..comment^))
             (<>.either ..text^))))
      (<>.before (<>.some ..null^))
      (<>.after (<>.maybe ..xml_header^))))

(def: (sanitize_value input)
  (-> Text Text)
  (|> input
      (text.replaced "&" "&amp;")
      (text.replaced "<" "&lt;")
      (text.replaced ">" "&gt;")
      (text.replaced "'" "&apos;")
      (text.replaced text.double_quote "&quot;")))

(def: .public (tag [namespace name])
  (-> Tag Text)
  (case namespace
    "" name
    _ ($_ text\compose namespace ..namespace_separator name)))

(def: .public attribute
  (-> Attribute Text)
  ..tag)

(def: xml_header
  Text
  (let [quote (: (-> Text Text)
                 (function (_ value)
                   ($_ text\compose text.double_quote value text.double_quote)))]
    ($_ text\compose
        "<?xml"
        " version=" (quote "1.0")
        " encoding=" (quote "UTF-8")
        "?>")))

(implementation: .public codec
  (Codec Text XML)
  
  (def: encode
    (let [attributes (: (-> Attrs Text)
                        (function (_ attrs)
                          (|> attrs
                              dictionary.entries
                              (list\map (function (_ [key value])
                                          ($_ text\compose (..attribute key) "=" text.double_quote (sanitize_value value) text.double_quote)))
                              (text.interposed " "))))]
      (function (_ input)
        ($_ text\compose
            ..xml_header text.new_line
            (loop [prefix ""
                   input input]
              (case input
                (#Text value)
                (sanitize_value value)

                (^ (#Node xml_tag xml_attrs (list (#Text value))))
                (let [tag (..tag xml_tag)
                      attrs (if (dictionary.empty? xml_attrs)
                              ""
                              ($_ text\compose " " (attributes xml_attrs)))]
                  ($_ text\compose
                      prefix "<" tag attrs ">"
                      (sanitize_value value)
                      "</" tag ">"))
                
                (#Node xml_tag xml_attrs xml_children)
                (let [tag (..tag xml_tag)
                      attrs (if (dictionary.empty? xml_attrs)
                              ""
                              ($_ text\compose " " (attributes xml_attrs)))]
                  (if (list.empty? xml_children)
                    ($_ text\compose prefix "<" tag attrs "/>")
                    ($_ text\compose prefix "<" tag attrs ">"
                        (|> xml_children
                            (list\map (|>> (recur (text\compose prefix text.tab)) (text\compose text.new_line)))
                            text.together)
                        text.new_line prefix "</" tag ">")))))
            ))))
  (def: decode
    (<text>.result ..xml^)))

(implementation: .public equivalence
  (Equivalence XML)
  
  (def: (= reference sample)
    (case [reference sample]
      [(#Text reference/value) (#Text sample/value)]
      (text\= reference/value sample/value)

      [(#Node reference/tag reference/attrs reference/children)
       (#Node sample/tag sample/attrs sample/children)]
      (and (name\= reference/tag sample/tag)
           (\ (dictionary.equivalence text.equivalence) = reference/attrs sample/attrs)
           (n.= (list.size reference/children)
                (list.size sample/children))
           (|> (list.zipped/2 reference/children sample/children)
               (list.every? (product.uncurried =))))

      _
      false)))