adam@9: open Parse
adam@9: 
adam@9: con attribute = fn t => {Nam : string,
adam@9:                          Parse : string -> option t}
adam@9: 
adam@9: con tag = fn ts => {Nam : string,
adam@9:                     Attributes : $(map attribute ts),
adam@9:                     Folder : folder ts,
adam@9:                     Construct : ctx ::: {Unit} -> [[Body] ~ ctx] => $ts
adam@9:                                 -> xml ([Body] ++ ctx) [] [] -> xml ([Body] ++ ctx) [] []}
adam@9: 
adam@9: fun tag [use] [ignore] [use ~ ignore] (fl : folder use) (name : string) (attrs : $(map attribute use))
adam@9:         (construct : ctx ::: {Unit} -> [[Body] ~ ctx] => Basis.tag (use ++ ignore) ([Body] ++ ctx) ([Body] ++ ctx) [] []) =
adam@9:     {Nam = name,
adam@9:      Attributes = attrs,
adam@9:      Folder = fl,
adam@9:      Construct = fn [ctx] [[Body] ~ ctx] (ats : $use) (inner : xml ([Body] ++ ctx) [] []) =>
adam@9:                     Basis.tag None ats construct inner}
adam@9: 
adam@9: fun simpleTag [ignore] name (bt : bodyTag ignore) : tag [] =
adam@9:     @@tag [[]] [ignore] ! _ name {} (fn [ctx] [[Body] ~ ctx] => bt ())
adam@9: 
adam@9: fun simpleTag' [use] [ignore] [use ~ ignore] (fl : folder use)
adam@9:                name (bt : bodyTag (use ++ ignore)) (ats : $(map attribute use)) : tag use =
adam@9:     @@tag [use] [ignore] ! fl name ats (fn [ctx] [[Body] ~ ctx] => bt ())
adam@9: 
adam@9: fun url name = {Nam = name,
adam@9:                 Parse = checkUrl}
adam@9: 
adam@9: datatype error a =
adam@9:          Good of a
adam@9:        | Bad of string
adam@9: 
adam@9: fun format [tags] (fl : folder tags) (tags : $(map tag tags)) [ctx] [[Body] ~ ctx] s =
adam@9:     let
adam@9:         fun loop s : error (xml ([Body] ++ ctx) [] [] * string) =
adam@9:             case String.msplit {Haystack = s, Needle = "&<"} of
adam@9:                 None => Good (cdata s, "")
adam@9:               | Some (pre, ch, post) =>
adam@9:                 case ch of
adam@9:                     #"&" =>
adam@9:                     (case String.split post #";" of
adam@9:                          None => Bad "No ';' after '&'"
adam@9:                        | Some (code, post) =>
adam@9:                          let
adam@9:                              val xml = 
adam@9:                                  case code of
adam@9:                                      "lt" => <xml>&lt;</xml>
adam@9:                                    | "gt" => <xml>&gt;</xml>
adam@9:                                    | "amp" => <xml>&amp;</xml>
adam@9:                                    | _ => <xml/>
adam@9:                          in
adam@9:                              case loop post of
adam@9:                                  Good (after, post) => Good (<xml>{[pre]}{xml}{after}</xml>, post)
adam@9:                                | x => x
adam@9:                          end)
adam@9:                   | _ =>
adam@9:                     if String.length post > 0 && String.sub post 0 = #"/" then
adam@9:                         case String.split post #"\x3E" of
adam@9:                             None => Bad "No '>' after '</'"
adam@9:                           | Some (_, post) => Good (<xml>{[pre]}</xml>, post)
adam@9:                     else
adam@9:                         case String.msplit {Haystack = post, Needle = " >"} of
adam@9:                             None => Bad "No '>' after '<'"
adam@9:                           | Some (tname, ch, post) =>
adam@9:                             @foldR [tag] [fn _ => unit -> error (xml ([Body] ++ ctx) [] [] * string)]
adam@9:                             (fn [nm :: Name] [ts :: {Type}] [r :: {{Type}}] [[nm] ~ r] (meta : tag ts) acc () =>
adam@9:                                 if meta.Nam = tname then
adam@9:                                     let
adam@9:                                         fun doAttrs (ch, post, ats : $(map option ts)) =
adam@9:                                             if String.length post > 0 && Char.isSpace (String.sub post 0) then
adam@9:                                                 doAttrs (ch, String.substring post {Start = 1,
adam@9:                                                                                     Len = String.length post - 1},
adam@9:                                                          ats)
adam@9:                                             else 
adam@9:                                                 case ch of
adam@9:                                                     #"\x3E" => Good (ats, post)
adam@9:                                                   | _ =>
adam@9:                                                     case String.split post #"=" of
adam@9:                                                         None =>
adam@9:                                                         (case String.split post #"\x3E" of
adam@9:                                                              None => Bad "No tag ender '\x3E'"
adam@9:                                                            | Some (_, post) => Good (ats, post))
adam@9:                                                       | Some (aname, post) =>
adam@9:                                                         if String.length post >= 1 && String.sub post 0 = #"\"" then
adam@9:                                                             case String.split (String.substring post
adam@9:                                                                                                 {Start = 1,
adam@9:                                                                                                  Len = String.length post
adam@9:                                                                                                        - 1})
adam@9:                                                                               #"\"" of
adam@9:                                                                 None => Bad "No '\"' to end attribute value"
adam@9:                                                               | Some (aval, post) =>
adam@9:                                                                 let
adam@9:                                                                     val ats =
adam@9:                                                                         @map2 [attribute] [option] [option]
adam@9:                                                                          (fn [t] meta v =>
adam@9:                                                                              if aname = meta.Nam then
adam@9:                                                                                  meta.Parse aval
adam@9:                                                                              else
adam@9:                                                                                  v)
adam@9:                                                                          meta.Folder meta.Attributes ats
adam@9:                                                                 in
adam@9:                                                                     doAttrs (#" ", post, ats)
adam@9:                                                                 end
adam@9:                                                         else
adam@9:                                                             Bad "Attribute value doesn't begin with quote"
adam@9:                                     in
adam@9:                                         case doAttrs (ch, post, @map0 [option] (fn [t :: Type] => None)
adam@9:                                                                  meta.Folder) of
adam@9:                                             Good (ats, post) =>
adam@9:                                             let
adam@9:                                                 val ats =
adam@9:                                                     @map2 [attribute] [option] [id]
adam@9:                                                      (fn [t] meta v =>
adam@9:                                                          case v of
adam@9:                                                              None => error <xml>Missing attribute {[meta.Nam]}
adam@9:                                                                for {[tname]}</xml>
adam@9:                                                            | Some v => v)
adam@9:                                                      meta.Folder meta.Attributes ats
adam@9:                                             in
adam@9:                                                 case loop post of
adam@9:                                                     Good (inner, post) =>
adam@9:                                                     (case loop post of
adam@9:                                                          Good (after, post) =>
adam@9:                                                          Good (<xml>{[pre]}{meta.Construct [ctx] !
adam@9:                                                                                            ats inner}{after}</xml>, post)
adam@9:                                                        | x => x)
adam@9:                                                   | x => x
adam@9:                                             end
adam@9:                                           | Bad s => Bad s
adam@9:                                     end
adam@9:                                 else
adam@9:                                     acc ())
adam@9:                             (fn () => Bad ("Unknown HTML tag " ^ tname)) fl tags ()
adam@9:     in
adam@9:         case loop s of
adam@9:             Bad msg => Failure msg
adam@9:           | Good (xml, _) => Success xml
adam@9:     end
adam@9: 
adam@9: val b = simpleTag "b" @@b
adam@9: val i = simpleTag "i" @@i
adam@9: val a = simpleTag' "a" @@a {Href = url "href"}
adam@9: