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

(;module: {#;doc "Functionality for reading, generating and processing values in the XML format."}
  lux
  (lux (control monad
                [eq #+ Eq]
                codec
                ["p" parser "p/" Monad<Parser>]
                ["ex" exception #+ exception:])
       (data [text "text/" Eq<Text> Monoid<Text>]
             (text ["l" lexer])
             [number]
             ["R" result]
             [product]
             [maybe "m/" Monad<Maybe>]
             [ident "ident/" Eq<Ident> Codec<Text,Ident>]
             (coll [list "L/" Monad<List>]
                   ["d" dict]))
       ))

(type: #export Tag Ident)
(type: #export Attrs (d;Dict Ident Text))

(def: #export attrs Attrs (d;new ident;Hash<Ident>))

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

(def: xml-standard-escape-char^
  (l;Lexer Text)
  ($_ p;either
      (p;after (l;this "&lt;") (p/wrap "<"))
      (p;after (l;this "&gt;") (p/wrap ">"))
      (p;after (l;this "&amp;") (p/wrap "&"))
      (p;after (l;this "&apos;") (p/wrap "'"))
      (p;after (l;this "&quot;") (p/wrap "\""))))

(def: xml-unicode-escape-char^
  (l;Lexer Text)
  (|> (do p;Monad<Parser>
        [hex? (p;opt (l;this "x"))
         code (case hex?
                #;None
                (p;codec number;Codec<Text,Int> (l;many l;decimal))

                (#;Some _)
                (p;codec number;Hex@Codec<Text,Int> (l;many l;hexadecimal)))]
        (wrap (|> code int-to-nat text;from-code)))
      (p;before (l;this ";"))
      (p;after (l;this "&#"))))

(def: xml-escape-char^
  (l;Lexer Text)
  (p;either xml-standard-escape-char^
            xml-unicode-escape-char^))

(def: xml-char^
  (l;Lexer Text)
  (p;either (l;none-of "<>&'\"")
            xml-escape-char^))

(def: xml-identifier
  (l;Lexer Text)
  (do p;Monad<Parser>
    [head (p;either (l;one-of "_")
                    l;alpha)
     tail (l;some (p;either (l;one-of "_.-")
                            l;alpha-num))]
    (wrap ($_ text/append head tail))))

(def: namespaced-symbol^
  (l;Lexer Ident)
  (do p;Monad<Parser>
    [first-part xml-identifier
     ?second-part (<| p;opt (p;after (l;this ":")) xml-identifier)]
    (case ?second-part
      #;None
      (wrap ["" first-part])

      (#;Some second-part)
      (wrap [first-part second-part]))))

(def: tag^ namespaced-symbol^)
(def: attr-name^ namespaced-symbol^)

(def: spaced^
  (All [a] (-> (l;Lexer a) (l;Lexer a)))
  (let [white-space^ (p;some l;space)]
    (|>. (p;before white-space^)
         (p;after white-space^))))

(def: attr-value^
  (l;Lexer Text)
  (let [value^ (l;some xml-char^)]
    (p;either (l;enclosed ["\"" "\""] value^)
              (l;enclosed ["'" "'"] value^))))

(def: attrs^
  (l;Lexer Attrs)
  (<| (:: p;Monad<Parser> map (d;from-list ident;Hash<Ident>))
      p;some
      (p;seq (spaced^ attr-name^))
      (p;after (l;this "="))
      (spaced^ attr-value^)))

(def: (close-tag^ expected)
  (-> Tag (l;Lexer []))
  (do p;Monad<Parser>
    [actual (|> tag^
                spaced^
                (p;after (l;this "/"))
                (l;enclosed ["<" ">"]))]
    (p;assert ($_ text/append "Close tag does not match open tag.\n"
                  "Expected: " (ident/encode expected) "\n"
                  "  Actual: " (ident/encode actual) "\n")
              (ident/= expected actual))))

(def: comment^
  (l;Lexer Text)
  (|> (l;not (l;this "--"))
      l;some
      (l;enclosed ["<--" "-->"])
      spaced^))

(def: xml-header^
  (l;Lexer Attrs)
  (|> (spaced^ attrs^)
      (p;before (l;this "?>"))
      (p;after (l;this "<?xml"))
      spaced^))

(def: cdata^
  (l;Lexer Text)
  (let [end (l;this "]]>")]
    (|> (l;some (l;not end))
        (p;after end)
        (p;after (l;this "<![CDATA["))
        spaced^)))

(def: text^
  (l;Lexer XML)
  (|> (p;either cdata^
                (l;many xml-char^))
      (p/map (|>. text;trim #Text))))

(def: xml^
  (l;Lexer XML)
  (|> (p;rec
       (function [node^]
         (p;either text^
                   (spaced^
                    (do p;Monad<Parser>
                      [_ (l;this "<")
                       tag (spaced^ tag^)
                       attrs (spaced^ attrs^)
                       #let [no-children^ (do p;Monad<Parser>
                                            [_ (l;this "/>")]
                                            (wrap (#Node tag attrs (list))))
                             with-children^ (do p;Monad<Parser>
                                              [_ (l;this ">")
                                               children (p;some node^)
                                               _ (close-tag^ tag)]
                                              (wrap (#Node tag attrs children)))]]
                      (p;either no-children^
                                with-children^))))))
      ## This is put outside of the call to "rec" because comments
      ## cannot be located inside of XML nodes.
      ## This way, the comments can only be before or after the main document.
      (p;before (p;some comment^))
      (p;after (p;some comment^))
      (p;after (p;opt xml-header^))))

(def: #export (read input)
  (-> Text (R;Result XML))
  (l;run input xml^))

(def: (sanitize-value input)
  (-> Text Text)
  (|> input
      (text;replace-all "&" "&amp;")
      (text;replace-all "<" "&lt;")
      (text;replace-all ">" "&gt;")
      (text;replace-all "'" "&apos;")
      (text;replace-all "\"" "&quot;")))

(def: (write-tag [namespace name])
  (-> Tag Text)
  (case namespace
    "" name
    _ ($_ text/append namespace ":" name)))

(def: (write-attrs attrs)
  (-> Attrs Text)
  (|> attrs
      d;entries
      (L/map (function [[key value]]
               ($_ text/append (write-tag key) "=" "\""(sanitize-value value) "\"")))
      (text;join-with " ")))

(def: xml-header
  Text
  "<?xml version=\"1.0\" encoding=\"UTF-8\"?>")

(def: #export (write input)
  (-> XML Text)
  ($_ text/append xml-header
      (loop [input input]
        (case input
          (#Text value)
          (sanitize-value value)
          
          (#Node xml-tag xml-attrs xml-children)
          (let [tag (write-tag xml-tag)
                attrs (if (d;empty? xml-attrs)
                        ""
                        ($_ text/append " " (write-attrs xml-attrs)))]
            (if (list;empty? xml-children)
              ($_ text/append "<" tag attrs "/>")
              ($_ text/append "<" tag attrs ">"
                  (|> xml-children
                      (L/map recur)
                      (text;join-with ""))
                  "</" tag ">")))))))

(struct: #export _ (Codec Text XML)
  (def: encode write)
  (def: decode read))

(struct: #export _ (Eq 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 (ident/= reference/tag sample/tag)
           (:: (d;Eq<Dict> text;Eq<Text>) = reference/attrs sample/attrs)
           (n.= (list;size reference/children)
                (list;size sample/children))
           (|> (list;zip2 reference/children sample/children)
               (list;every? (product;uncurry =))))

      _
      false)))

(type: #export (Reader a)
  (p;Parser (List XML) a))

(exception: #export Empty-Input)
(exception: #export Unexpected-Input)
(exception: #export Unknown-Attribute)
(exception: #export Wrong-Tag)
(exception: #export Unconsumed-Inputs)

(def: #export text
  (Reader Text)
  (function [docs]
    (case docs
      #;Nil
      (ex;throw Empty-Input "")
      
      (#;Cons head tail)
      (case head
        (#Text value)
        (#R;Success [tail value])
        
        (#Node _)
        (ex;throw Unexpected-Input "")))))

(def: #export (attr name)
  (-> Ident (Reader Text))
  (function [docs]
    (case docs
      #;Nil
      (ex;throw Empty-Input "")
      
      (#;Cons head _)
      (case head
        (#Text _)
        (ex;throw Unexpected-Input "")
        
        (#Node tag attrs children)
        (case (d;get name attrs)
          #;None
          (ex;throw Unknown-Attribute "")
          
          (#;Some value)
          (#R;Success [docs value]))))))

(def: (run' docs reader)
  (All [a] (-> (List XML) (Reader a) (R;Result a)))
  (case (p;run docs reader)
    (#R;Success [remaining output])
    (if (list;empty? remaining)
      (#R;Success output)
      (ex;throw Unconsumed-Inputs (|> remaining
                                      (L/map (:: Codec<Text,XML> encode))
                                      (text;join-with "\n\n"))))
    
    (#R;Error error)
    (#R;Error error)))

(def: #export (node tag)
  (-> Ident (Reader Unit))
  (function [docs]
    (case docs
      #;Nil
      (ex;throw Empty-Input "")
      
      (#;Cons head _)
      (case head
        (#Text _)
        (ex;throw Unexpected-Input "")
        
        (#Node _tag _attrs _children)
        (if (ident/= tag _tag)
          (#R;Success [docs []])
          (ex;throw Wrong-Tag (ident/encode tag)))))))

(def: #export (children reader)
  (All [a] (-> (Reader a) (Reader a)))
  (function [docs]
    (case docs
      #;Nil
      (ex;throw Empty-Input "")
      
      (#;Cons head tail)
      (case head
        (#Text _)
        (ex;throw Unexpected-Input "")
        
        (#Node _tag _attrs _children)
        (do R;Monad<Result>
          [output (run' _children reader)]
          (wrap [tail output]))))))

(def: #export ignore
  (Reader Unit)
  (function [docs]
    (case docs
      #;Nil
      (ex;throw Empty-Input "")
      
      (#;Cons head tail)
      (#R;Success [tail []]))))

(def: #export (run document reader)
  (All [a] (-> XML (Reader a) (R;Result a)))
  (run' (list document) reader))