adam@0: task initialize = fn () => FeedFfi.init
adam@0: 
adam@4: con pattern internal output = {Initial : internal,
adam@4:                                EnterTag : {Tag : string, Attrs : list (string * string), Cdata : option string} -> internal -> option internal,
adam@4:                                ExitTag : internal -> option internal,
adam@4:                                Finished : internal -> option (output * bool)}
adam@4: 
adam@4: val null : pattern unit (variant []) =
adam@4:     {Initial = (),
adam@4:      EnterTag = fn _ () => Some (),
adam@4:      ExitTag = fn () => Some (),
adam@4:      Finished = fn () => None}
adam@1: 
adam@6: con tagInternal (attrs :: {Unit}) = option {Attrs : $(mapU (option string) attrs), Cdata : option string}
adam@1: 
adam@6: fun tagG [attrs ::: {Unit}] [t ::: Type] (fl : folder attrs) (accept : {Attrs : $(mapU (option string) attrs), Cdata : option string} -> option t)
adam@3:          (name : string) (attrs : $(mapU string attrs))
adam@3:     : pattern (tagInternal attrs) t =
adam@4:     {Initial = None,
adam@4:      EnterTag = fn tinfo _ =>
adam@4:                    if tinfo.Tag <> name then
adam@4:                        None
adam@4:                    else
adam@6:                        let
adam@6:                            val v = {Attrs = @mp [fn _ => string] [fn _ => option string]
adam@6:                                              (fn [u] aname => List.assoc aname tinfo.Attrs)
adam@6:                                              fl attrs,
adam@6:                                     Cdata = tinfo.Cdata}
adam@6:                        in
adam@6:                            case accept v of
adam@6:                                None => None
adam@6:                              | Some _ => Some (Some v)
adam@6:                        end,
adam@4:      ExitTag = fn _ => None,
adam@4:      Finished = fn state => case state of
adam@4:                                 None => None
adam@4:                               | Some state =>
adam@4:                                 case accept state of
adam@4:                                     None => None
adam@4:                                   | Some v => Some (v, False)}
adam@3: 
adam@6: fun allPresent [attrs ::: {Unit}] (fl : folder attrs) (attrs : $(mapU (option string) attrs)) : option $(mapU string attrs) =
adam@6:     @foldUR [option string] [fn attrs => option $(mapU string attrs)]
adam@6:     (fn [nm ::_] [r ::_] [[nm] ~ r] os acc =>
adam@6:         case (os, acc) of
adam@6:             (Some s, Some acc) => Some ({nm = s} ++ acc)
adam@6:           | _ => None)
adam@6:     (Some {}) fl attrs
adam@6: 
kkallio@9: fun allPresentE [attrs ::: {Unit}] (fl : folder attrs) (vs : $(mapU (option string) attrs)) (attrs : $(mapU (option string) attrs))
kkallio@9:     : option $(mapU string attrs) =
kkallio@9:     @foldUR2 [option string] [option string] [fn attrs => option $(mapU string attrs)]
kkallio@9:     (fn [nm ::_] [r ::_] [[nm] ~ r] os os' acc =>
kkallio@9:         case (os, os', acc) of
kkallio@9:             (Some s, Some s', Some acc) => if s = s' then Some ({nm = s'} ++ acc) else None
kkallio@9:           | (None, Some s', Some acc) => Some ({nm = s'} ++ acc)
kkallio@9:           | _ => None)
kkallio@9:     (Some {}) fl vs attrs
kkallio@9: 
adam@3: fun tag [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU string attrs))
adam@3:     : pattern (tagInternal attrs) {Attrs : $(mapU string attrs), Cdata : option string} =
adam@6:     @tagG fl (fn r =>
adam@6:                  case @allPresent fl r.Attrs of
adam@6:                      None => None
adam@6:                    | Some attrs => Some (r -- #Attrs ++ {Attrs = attrs}))
adam@6:      name attrs
adam@3: 
adam@3: fun tagA [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU string attrs))
adam@3:     : pattern (tagInternal attrs) $(mapU string attrs) =
adam@6:     @tagG fl (fn r => @allPresent fl r.Attrs) name attrs
kkallio@9: 
kkallio@9: fun tagAV [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU (string * option string) attrs))
kkallio@9:     : pattern (tagInternal attrs) $(mapU string attrs) =
kkallio@9:     let
kkallio@9:         val as = @mp [fn _ => (string * option string)] [fn _ => string] (fn [u] (x, _) => x) fl attrs
kkallio@9:         val vs = @mp [fn _ => (string * option string)] [fn _ => option string] (fn [u] (_, x) => x) fl attrs
kkallio@9:     in
kkallio@9:         @tagG fl (fn r => @allPresentE fl vs r.Attrs) name as
kkallio@9:     end
kkallio@9: 
adam@6: fun tagAO [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU string attrs))
adam@6:     : pattern (tagInternal attrs) $(mapU (option string) attrs) =
adam@6:     @tagG fl (fn r => Some (r.Attrs)) name attrs
adam@3: 
adam@3: fun tagC (name : string) : pattern (tagInternal []) string =
adam@3:     tagG (fn r => r.Cdata) name {}
adam@1: 
adam@4: datatype status a = Initial | Pending of a | Matched of a
adam@1: 
adam@1: con childrenInternal (parent :: Type) (children :: {Type}) = option (parent * int * $(map status children))
adam@1: 
adam@6: fun childrenG [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}] [t ::: Type]
adam@6:               (ready : $(map (fn (i, d) => option d) children) -> option t)
adam@6:               (parent : pattern parentI parent) (children : $(map (fn (i, d) => pattern i d) children)) (fl : folder children)
adam@6:     : pattern (childrenInternal parentI (map fst children)) (parent * t) =
adam@4:       {Initial = None,
adam@4:        EnterTag = fn tinfo state =>
adam@4:                      case state of
adam@4:                          None =>
adam@4:                          (case parent.EnterTag tinfo parent.Initial of
adam@4:                               None => None
adam@4:                             | Some pstate => Some (Some (pstate, 1, @map0 [status] (fn [t ::_] => Initial)
adam@4:                                                                      (@@Folder.mp [fst] [_] fl))))
adam@4:                        | Some (pstate, depth, cstates) =>
adam@6:                          if depth = 0 then
adam@6:                              case parent.EnterTag tinfo parent.Initial of
adam@6:                                  None => None
adam@6:                                | Some pstate => Some (Some (pstate, 1, @map0 [status] (fn [t ::_] => Initial)
adam@6:                                                                         (@@Folder.mp [fst] [_] fl)))
adam@6:                          else
adam@6:                              Some (Some (pstate,
adam@6:                                          depth+1,
adam@6:                                          @map2 [fn (i, d) => pattern i d] [fn (i, d) => status i] [fn (i, d) => status i]
adam@6:                                           (fn [p] (ch : pattern p.1 p.2) (cstate : status p.1) =>
adam@6:                                               case cstate of
adam@6:                                                   Initial =>
adam@6:                                                   (case ch.EnterTag tinfo ch.Initial of
adam@6:                                                        None => Initial
adam@6:                                                      | Some v =>
adam@6:                                                        case ch.Finished v of
adam@6:                                                            None => Pending v
adam@6:                                                          | _ => Matched v)
adam@6:                                                 | Pending cstate =>
adam@6:                                                   (case ch.EnterTag tinfo cstate of
adam@6:                                                        None => Initial
adam@6:                                                      | Some v =>
adam@6:                                                        case ch.Finished v of
adam@6:                                                            None => Pending v
adam@6:                                                          | _ => Matched v)
adam@6:                                                 | v => v)
adam@6:                                           fl children cstates)),
adam@4:        ExitTag = fn state =>
adam@4:                     case state of
adam@4:                         None => None
adam@6:                       | Some (pstate, 1, cstates) => Some (Some (pstate, 0, cstates))
adam@4:                       | Some (pstate, depth, cstates) =>
adam@4:                         Some (Some (pstate, depth-1,
adam@4:                                     @map2 [fn (i, d) => pattern i d] [fn (i, d) => status i] [fn (i, d) => status i]
adam@4:                                      (fn [p] (ch : pattern p.1 p.2) (cstate : status p.1) =>
adam@4:                                          case cstate of
adam@4:                                              Pending cstate =>
adam@4:                                              (case ch.ExitTag cstate of
adam@4:                                                   None => Initial
adam@4:                                                 | Some cstate' =>
adam@4:                                                   case ch.Finished cstate' of
adam@4:                                                       None => Pending cstate'
adam@4:                                                     | _ => Matched cstate')
adam@4:                                            | _ => cstate)
adam@4:                               fl children cstates)),
adam@4:        Finished = fn state =>
adam@4:                      case state of
adam@6:                          Some (pstate, 0, cstates) =>
adam@4:                          (case parent.Finished pstate of
adam@4:                               None => None
adam@4:                             | Some (pdata, pcont) =>
adam@6:                               case ready (@map2 [fn (i, d) => status i] [fn (i, d) => pattern i d] [fn (i, d) => option d]
adam@6:                                            (fn [p] (cstate : status p.1) (ch : pattern p.1 p.2) =>
adam@6:                                                case cstate of
adam@6:                                                    Matched v => Option.mp (fn p => p.1) (ch.Finished v)
adam@6:                                                  | _ => None) fl cstates children) of
adam@4:                                   None => None
adam@4:                                 | Some cdata => Some ((pdata, cdata), pcont))
adam@4:                        | _ => None}
adam@1: 
adam@6: fun children [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}]
adam@6:              (parent : pattern parentI parent) (children : $(map (fn (i, d) => pattern i d) children)) (fl : folder children)
adam@6:     : pattern (childrenInternal parentI (map fst children)) (parent * $(map snd children)) =
adam@6:       @childrenG (@foldR [fn (i, d) => option d] [fn cs => option $(map snd cs)]
adam@6:                    (fn [nm ::_] [p ::_] [r ::_] [[nm] ~ r] (cstate : option p.2) acc =>
adam@6:                        case (cstate, acc) of
adam@6:                            (Some cstate, Some acc) => Some ({nm = cstate} ++ acc)
adam@6:                          | _ => None)
adam@6:                    (Some {}) fl) parent children fl
adam@6: 
adam@6: fun childrenO [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}]
adam@6:              (parent : pattern parentI parent) (children : $(map (fn (i, d) => pattern i d) children)) (fl : folder children)
adam@6:     : pattern (childrenInternal parentI (map fst children)) (parent * $(map (fn (i, d) => option d) children)) =
adam@6:       @childrenG Some parent children fl
adam@6: 
kkallio@11: datatype required t = Required of t | Optional of t
kkallio@11: 
kkallio@11: fun childrenO' [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}]
kkallio@11:               (parent : pattern parentI parent) (children : $(map (fn (i, d) => required (pattern i d)) children)) (fl : folder children)
kkallio@11:     : pattern (childrenInternal parentI (map fst children)) (parent * $(map (fn (i, d) => option d) children)) =
kkallio@11:       let
kkallio@11:         val os = @mp [fn (i, d) => required (pattern i d)] [fn (i, d) => bool] 
kkallio@11:                   (fn [u] pat => case pat of
kkallio@11:                                      Required _ => False
kkallio@11:                                    | Optional _ => True) fl children
kkallio@11:         val vs = @mp [fn (i, d) => required (pattern i d)] [fn (i, d) => pattern i d]
kkallio@11:                   (fn [u] pat => case pat of
kkallio@11:                                      Required pat' => pat'
kkallio@11:                                    | Optional pat' => pat') fl children
kkallio@11:       in
kkallio@11:           @childrenG (@foldR2 [fn _ => bool] [fn (i, d) => option d] [fn r => option $(map (fn (i, d) => option d) r)]
kkallio@11:                        (fn [nm ::_] [p ::_] [r ::_] [[nm] ~ r] (isO : bool) (cstate : option p.2) acc =>
kkallio@11:                            case acc of
kkallio@11:                                None => None
kkallio@11:                              | Some acc =>
kkallio@11:                                if isO then
kkallio@11:                                    Some ({nm = cstate} ++ acc)
kkallio@11:                                else
kkallio@11:                                    case cstate of
kkallio@11:                                        None => None
kkallio@11:                                      | Some _ => Some ({nm = cstate} ++ acc))
kkallio@11:                        (Some {}) fl os) parent vs fl
kkallio@11:       end
kkallio@11:           
adam@4: con treeInternal (parent :: Type) (child :: Type) = option (parent * int * option child)
adam@4: 
adam@4: fun tree [parentI ::: Type] [parent ::: Type] [childI ::: Type] [child ::: Type]
adam@4:     (parent : pattern parentI parent) (child : pattern childI child)
adam@4:     : pattern (treeInternal parentI childI) (parent * child) =
adam@4:     {Initial = None,
adam@4:      EnterTag = fn tinfo state =>
adam@4:                    case state of
adam@4:                        None =>
adam@4:                        (case parent.EnterTag tinfo parent.Initial of
adam@4:                             None => None
adam@4:                           | Some pstate => Some (Some (pstate, 1, None)))
adam@4:                      | Some (pstate, depth, cstate) =>
adam@4:                        Some (Some (pstate,
adam@4:                                    depth+1,
adam@4:                                    child.EnterTag tinfo (Option.get child.Initial cstate))),
adam@4:      ExitTag = fn state =>
adam@4:                   case state of
adam@4:                       None => None
adam@6:                     | Some (_, 1, _) => None
adam@4:                     | Some (pstate, depth, cstate) =>
adam@4:                       Some (Some (pstate, depth-1, Option.bind child.ExitTag cstate)),
adam@4:      Finished = fn state =>
adam@4:                    case state of
adam@4:                        None => None
adam@4:                      | Some (pstate, _, cstate) =>
adam@4:                        case parent.Finished pstate of
adam@4:                            None => None
adam@4:                          | Some (pdata, _) =>
adam@4:                            case cstate of
adam@4:                                None => None
adam@4:                              | Some cstate =>
adam@4:                                case child.Finished cstate of
adam@4:                                    None => None
adam@4:                                  | Some (cdata, _) => Some ((pdata, cdata), True)}
adam@4: 
adam@5: type document = string
adam@7: val show_document = _
adam@5: 
adam@5: val fetch = FeedFfi.fetch
adam@5: 
kkallio@10: fun app' [internal ::: Type] [data ::: Type] [acc ::: Type] (p : pattern internal data) (f : data -> acc -> transaction acc) 
kkallio@10:         (doc : document) (acc : acc) : transaction acc =
adam@1:     let
kkallio@10:         fun recur xml acc state =
adam@4:             case String.seek xml #"<" of
kkallio@10:                 None => return acc
adam@4:               | Some xml =>
adam@1:                 if xml <> "" && String.sub xml 0 = #"/" then
adam@4:                     case String.seek xml #"\x3E" of
kkallio@10:                         None => return acc
adam@4:                       | Some xml =>
adam@1:                         case p.ExitTag state of
kkallio@10:                             None => recur xml acc p.Initial
adam@1:                           | Some state =>
adam@1:                             case p.Finished state of
kkallio@10:                                  None => recur xml acc state 
adam@4:                                | Some (data, cont) =>
kkallio@10:                                  acc <- f data acc;
kkallio@10:                                  recur xml acc (if cont then state else p.Initial)
adam@1:                 else if xml <> "" && String.sub xml 0 = #"?" then
adam@4:                     case String.seek xml #"\x3E" of
kkallio@10:                         None => return acc
kkallio@10:                       | Some xml => recur xml acc state
adam@1:                 else if xml <> "" && String.sub xml 0 = #"!" then
adam@2:                     if String.lengthGe xml 3 && String.sub xml 1 = #"-" && String.sub xml 2 = #"-" then
adam@1:                         let
adam@1:                             fun skipper xml =
adam@4:                                 case String.seek xml #"-" of
adam@1:                                     None => xml
adam@4:                                   | Some xml =>
adam@2:                                     if String.lengthGe xml 2 && String.sub xml 0 = #"-" && String.sub xml 1 = #"\x3E" then
adam@1:                                         String.suffix xml 2
adam@1:                                     else
adam@1:                                         skipper xml
adam@1:                         in
kkallio@10:                             recur (skipper (String.suffix xml 3)) acc state
adam@1:                         end
adam@1:                     else
adam@4:                         case String.seek xml #"]" of
kkallio@10:                             None => return acc
adam@4:                           | Some xml =>
adam@4:                             case String.seek xml #"\x3E" of
kkallio@10:                                 None => return acc
kkallio@10:                               | Some xml => recur xml acc state
adam@1:                 else
adam@1:                     case String.msplit {Needle = " >/", Haystack = xml} of
kkallio@10:                         None => return acc
adam@1:                       | Some (tagName, ch, xml) =>
adam@1:                         let
adam@1:                             fun readAttrs ch xml acc =
adam@1:                                 case ch of
adam@1:                                     #"\x3E" => (xml, acc, False)
adam@1:                                   | #"/" =>
adam@4:                                     (case String.seek xml #"\x3E" of
adam@1:                                          None => (xml, acc, True)
adam@4:                                        | Some xml => (xml, acc, True))
adam@1:                                   | _ =>
adam@2:                                     if String.lengthGe xml 2 && Char.isSpace (String.sub xml 0) then
adam@1:                                         readAttrs (String.sub xml 0) (String.suffix xml 1) acc
adam@1:                                     else if xml <> "" && String.sub xml 0 = #"\x3E" then
adam@1:                                         (String.suffix xml 1, acc, False)
adam@1:                                     else if xml <> "" && String.sub xml 0 = #"/" then
adam@4:                                         (case String.seek xml #"\x3E" of
adam@1:                                              None => (xml, acc, True)
adam@4:                                            | Some xml => (xml, acc, True))
adam@1:                                     else
adam@1:                                         case String.split xml #"=" of
adam@1:                                             None => (xml, acc, False)
adam@1:                                           | Some (aname, xml) =>
adam@6:                                             if xml = "" || (String.sub xml 0 <> #"\"" && String.sub xml 0 <> #"'") then
adam@1:                                                 (xml, (aname, "") :: acc, False)
adam@1:                                             else
adam@6:                                                 case String.split (String.suffix xml 1) (String.sub xml 0) of
adam@1:                                                     None => (xml, (aname, "") :: acc, False)
adam@1:                                                   | Some (value, xml) =>
adam@1:                                                     if xml = "" then
adam@1:                                                         (xml, (aname, value) :: acc, False)
adam@1:                                                     else
adam@1:                                                         readAttrs (String.sub xml 0) (String.suffix xml 1) ((aname, value) :: acc)
adam@1: 
adam@1:                             val (xml, attrs, ended) = readAttrs ch xml []
adam@1: 
adam@1:                             fun skipSpaces xml =
adam@1:                                 if xml <> "" && Char.isSpace (String.sub xml 0) then
adam@1:                                     skipSpaces (String.suffix xml 1)
adam@1:                                 else
adam@1:                                     xml
adam@1: 
adam@1:                             val xml = skipSpaces xml
adam@1: 
adam@1:                             val (xml, cdata) =
adam@1:                                 if ended then
adam@1:                                     (xml, None)
adam@1:                                 else if String.isPrefix {Prefix = "<![CDATA[", Full = xml} then
adam@1:                                     let
adam@1:                                         fun skipper xml acc =
adam@1:                                             case String.split xml #"]" of
adam@1:                                                 None => (acc ^ xml, None)
adam@1:                                               | Some (pre, xml) =>
adam@2:                                                 if String.lengthGe xml 2 && String.sub xml 0 = #"]" && String.sub xml 1 = #"\x3E" then
adam@1:                                                     (String.suffix xml 2, Some (acc ^ pre))
adam@1:                                                 else
adam@1:                                                     skipper xml (acc ^ "]" ^ pre)
adam@1:                                     in
adam@1:                                         skipper (String.suffix xml 9) ""
adam@1:                                     end
adam@1:                                 else
adam@4:                                     case String.split' xml #"<" of
adam@1:                                         None => (xml, None)
adam@4:                                       | Some (cdata, xml) => (xml, Some cdata)
adam@1:                         in
adam@1:                             case p.EnterTag {Tag = tagName, Attrs = attrs, Cdata = cdata} state of
kkallio@10:                                 None => recur xml acc p.Initial
adam@1:                               | Some state =>
adam@4:                                 case p.Finished state of
adam@4:                                      None =>
adam@4:                                      (case (if ended then p.ExitTag state else Some state) of
kkallio@10:                                           None => recur xml acc p.Initial
adam@4:                                         | Some state =>
adam@4:                                           case p.Finished state of
kkallio@10:                                               None => recur xml acc state
adam@4:                                             | Some (data, cont) =>
kkallio@10:                                               acc <- f data acc;
kkallio@10:                                               recur xml acc (if cont then state else p.Initial))
adam@4:                                    | Some (data, cont) =>
kkallio@10:                                      acc <- f data acc;
kkallio@10:                                      recur xml acc (if cont then state else p.Initial)
adam@1:                         end
adam@1:     in
kkallio@10:         recur doc acc p.Initial
adam@1:     end
kkallio@10: 
kkallio@10: fun app [internal ::: Type] [data ::: Type] (p : pattern internal data) (f : data -> transaction {}) (doc : document) : transaction {} =
kkallio@10:     app' p (fn data acc => f data) doc ()