(.using
 [library
  [lux {"-" symbol}
   [abstract
    [monad {"+" do}]
    [equivalence {"+" Equivalence}]
    [codec {"+" Codec}]]
   [control
    [try {"+" Try}]
    ["<>" parser ("[1]#[0]" monad)
     ["<[0]>" text {"+" Parser Slice}]]]
   [data
    ["[0]" product]
    ["[0]" text {"+" \n} ("[1]#[0]" equivalence monoid)]
    [collection
     ["[0]" list ("[1]#[0]" functor)]
     ["[0]" dictionary {"+" Dictionary}]]]
   [math
    [number
     ["n" nat]
     ["[0]" int]]]
   [meta
    ["[0]" symbol ("[1]#[0]" equivalence codec)]]]])

(type: .public Tag
  Symbol)

(type: .public Attribute
  Symbol)

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

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

(type: .public XML
  (Rec XML
    (Variant
     {#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"))]
        (<| (# ! each (|>> .nat text.of_char))
            (<>.codec int.decimal)
            <text>.slice
            <text>.many!
            (case hex?
              {.#None}
              <text>.decimal!

              {.#Some _}
              <text>.hexadecimal!)))
      (<>.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#composite "<>&" text.double_quote))
             xml_escape_char^))

(def: xml_identifier
  (Parser Text)
  (<text>.slice
   ($_ <text>.and!
       (<>.either (<text>.one_of! "_")
                  <text>.alpha!)
       (<text>.some! (<>.either (<text>.one_of! "_.-")
                                <text>.alpha_num!)))))

(def: namespaced_symbol^
  (Parser Symbol)
  (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 each (dictionary.of_list symbol.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#composite "Close tag does not match open tag." \n
                      "Expected: " (symbol#encoded expected) \n
                      "  Actual: " (symbol#encoded actual) \n)
                  (symbol#= expected actual))))

(def: comment^
  (Parser Slice)
  (|> (<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 Slice)
  (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 (<text>.slice cdata^))
      (<>#each (|>> {#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#composite namespace ..namespace_separator name)))

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

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

(implementation: .public codec
  (Codec Text XML)
  
  (def: encoded
    (let [attributes (is (-> Attrs Text)
                         (function (_ attrs)
                           (|> attrs
                               dictionary.entries
                               (list#each (function (_ [key value])
                                            ($_ text#composite (..attribute key) "=" text.double_quote (sanitize_value value) text.double_quote)))
                               (text.interposed " "))))]
      (function (_ input)
        ($_ text#composite
            ..xml_header text.new_line
            (loop (again [prefix ""
                          input input])
              (case input
                {#Text value}
                (sanitize_value value)

                (pattern {#Node xml_tag xml_attrs (list {#Text value})})
                (let [tag (..tag xml_tag)
                      attrs (if (dictionary.empty? xml_attrs)
                              ""
                              ($_ text#composite " " (attributes xml_attrs)))]
                  ($_ text#composite
                      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#composite " " (attributes xml_attrs)))]
                  (if (list.empty? xml_children)
                    ($_ text#composite prefix "<" tag attrs "/>")
                    ($_ text#composite prefix "<" tag attrs ">"
                        (|> xml_children
                            (list#each (|>> (again (text#composite prefix text.tab)) (text#composite text.new_line)))
                            text.together)
                        text.new_line prefix "</" tag ">")))))
            ))))
  (def: decoded
    (<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 (symbol#= 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)))