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: kkallio@14: con gatherInternal (parent :: Type) (child :: Type) (data :: Type) = option (parent * bool * int * option child * list data) kkallio@14: kkallio@14: fun gather [parentI ::: Type] [parent ::: Type] [childI ::: Type] [child ::: Type] kkallio@14: (parent : pattern parentI parent) (child : pattern childI child) kkallio@14: : pattern (gatherInternal parentI childI child) (parent * list child) = kkallio@14: {Initial = None, kkallio@14: EnterTag = fn tinfo state => kkallio@14: case state of kkallio@14: None => kkallio@14: (case parent.EnterTag tinfo parent.Initial of kkallio@14: None => None kkallio@14: | Some pstate => Some (Some (pstate, False, 1, None, Nil))) kkallio@14: | Some (pstate, return, depth, cstate, clist) => kkallio@14: let kkallio@14: val cstate' = child.EnterTag tinfo (Option.get child.Initial cstate) kkallio@14: in kkallio@14: case child.Finished (Option.get child.Initial cstate') of kkallio@14: None => kkallio@14: Some (Some (pstate, return, depth+1, cstate', clist)) kkallio@14: | Some (cdata, _) => kkallio@14: Some (Some (pstate, return, depth+1, None, cdata :: clist)) kkallio@14: end, kkallio@14: ExitTag = fn state => kkallio@14: case state of kkallio@14: None => None kkallio@14: | Some (pstate, _, 1, cstate, clist) => kkallio@14: Some (Some (pstate, True, 1, cstate, clist)) kkallio@14: | Some (pstate, return, depth, cstate, clist) => kkallio@14: let kkallio@14: val cstate' = child.ExitTag (Option.get child.Initial cstate) kkallio@14: in kkallio@14: case child.Finished (Option.get child.Initial cstate') of kkallio@14: None => kkallio@14: Some (Some (pstate, return, depth-1, cstate', clist)) kkallio@14: | Some (cdata, _) => kkallio@14: Some (Some (pstate, return, depth-1, None, cdata :: clist)) kkallio@14: end, kkallio@14: Finished = fn state => kkallio@14: case state of kkallio@14: None => None kkallio@14: | Some (pstate, return, _, _, clist) => kkallio@14: case parent.Finished pstate of kkallio@14: None => None kkallio@14: | Some (pdata, _) => kkallio@14: if return then kkallio@14: Some ((pdata, List.rev clist), False) kkallio@14: else kkallio@14: None} kkallio@14: 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 = " (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@13: state <- return (if ended then kkallio@13: Option.get p.Initial (p.ExitTag state) kkallio@13: else kkallio@13: state); kkallio@13: 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 ()