(.require
 [library
  [lux (.except symbol)
   [abstract
    [monad (.only do)]
    [equivalence (.only Equivalence)]
    [codec (.only Codec)]]
   [control
    [try (.only Try)]
    ["<>" parser (.use "[1]#[0]" monad)]]
   [data
    ["[0]" product]
    ["[0]" text (.only \n) (.use "[1]#[0]" equivalence monoid)
     ["<[1]>" \\parser (.only Parser Slice)]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor)]
     ["[0]" dictionary (.only Dictionary)]]]
   [math
    [number
     ["n" nat]
     ["[0]" int]]]
   [meta
    ["[0]" symbol (.use "[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)
  (all <>.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"))]
        (<| (at ! 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 (all text#composite "<>&" text.double_quote))
             xml_escape_char^))

(def xml_identifier
  (Parser Text)
  (<text>.slice
   (all <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)
  (<| (at <>.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 (all 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^ (all <>.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}))]]
               (all <>.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
    _ (all text#composite namespace ..namespace_separator name)))

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

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

(def .public codec
  (Codec Text XML)
  (implementation
   (def encoded
     (let [attributes (is (-> Attrs Text)
                          (function (_ attrs)
                            (|> attrs
                                dictionary.entries
                                (list#each (function (_ [key value])
                                             (all text#composite (..attribute key) "=" text.double_quote (sanitize_value value) text.double_quote)))
                                (text.interposed " "))))]
       (function (_ input)
         (all 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)
                                ""
                                (all text#composite " " (attributes xml_attrs)))]
                    (all 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)
                                ""
                                (all text#composite " " (attributes xml_attrs)))]
                    (if (list.empty? xml_children)
                      (all text#composite prefix "<" tag attrs "/>")
                      (all 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^))))

(def .public equivalence
  (Equivalence XML)
  (implementation
   (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)
            (at (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))))