Mercurial > feed
changeset 6:e0bae488825c
'O' versions of tagA and children
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Sat, 15 Jan 2011 15:25:22 -0500 |
| parents | 2717458d8951 |
| children | 05a28a77f6fe |
| files | src/ur/feed.ur src/ur/feed.urs |
| diffstat | 2 files changed, 91 insertions(+), 69 deletions(-) [+] |
line wrap: on
line diff
--- a/src/ur/feed.ur Thu Jan 13 10:02:37 2011 -0500 +++ b/src/ur/feed.ur Sat Jan 15 15:25:22 2011 -0500 @@ -11,9 +11,9 @@ ExitTag = fn () => Some (), Finished = fn () => None} -con tagInternal (attrs :: {Unit}) = option {Attrs : $(mapU string attrs), Cdata : option string} +con tagInternal (attrs :: {Unit}) = option {Attrs : $(mapU (option string) attrs), Cdata : option string} -fun tagG [attrs ::: {Unit}] [t ::: Type] (fl : folder attrs) (accept : {Attrs : $(mapU string attrs), Cdata : option string} -> option t) +fun tagG [attrs ::: {Unit}] [t ::: Type] (fl : folder attrs) (accept : {Attrs : $(mapU (option string) attrs), Cdata : option string} -> option t) (name : string) (attrs : $(mapU string attrs)) : pattern (tagInternal attrs) t = {Initial = None, @@ -21,24 +21,16 @@ if tinfo.Tag <> name then None else - case @foldUR [string] [fn r => option $(mapU string r)] - (fn [nm ::_] [r ::_] [[nm] ~ r] aname ro => - case ro of - None => None - | Some r => - case List.assoc aname tinfo.Attrs of - None => None - | Some v => Some ({nm = v} ++ r)) - (Some {}) fl attrs of - None => None - | Some vs => - let - val v = {Attrs = vs, Cdata = tinfo.Cdata} - in - case accept v of - None => None - | Some _ => Some (Some v) - end, + let + val v = {Attrs = @mp [fn _ => string] [fn _ => option string] + (fn [u] aname => List.assoc aname tinfo.Attrs) + fl attrs, + Cdata = tinfo.Cdata} + in + case accept v of + None => None + | Some _ => Some (Some v) + end, ExitTag = fn _ => None, Finished = fn state => case state of None => None @@ -47,13 +39,28 @@ None => None | Some v => Some (v, False)} +fun allPresent [attrs ::: {Unit}] (fl : folder attrs) (attrs : $(mapU (option string) attrs)) : option $(mapU string attrs) = + @foldUR [option string] [fn attrs => option $(mapU string attrs)] + (fn [nm ::_] [r ::_] [[nm] ~ r] os acc => + case (os, acc) of + (Some s, Some acc) => Some ({nm = s} ++ acc) + | _ => None) + (Some {}) fl attrs + fun tag [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU string attrs)) : pattern (tagInternal attrs) {Attrs : $(mapU string attrs), Cdata : option string} = - @tagG fl Some name attrs + @tagG fl (fn r => + case @allPresent fl r.Attrs of + None => None + | Some attrs => Some (r -- #Attrs ++ {Attrs = attrs})) + name attrs fun tagA [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU string attrs)) : pattern (tagInternal attrs) $(mapU string attrs) = - @tagG fl (fn r => Some r.Attrs) name attrs + @tagG fl (fn r => @allPresent fl r.Attrs) name attrs +fun tagAO [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU string attrs)) + : pattern (tagInternal attrs) $(mapU (option string) attrs) = + @tagG fl (fn r => Some (r.Attrs)) name attrs fun tagC (name : string) : pattern (tagInternal []) string = tagG (fn r => r.Cdata) name {} @@ -62,9 +69,10 @@ con childrenInternal (parent :: Type) (children :: {Type}) = option (parent * int * $(map status children)) -fun children [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}] - (parent : pattern parentI parent) (children : $(map (fn (i, d) => pattern i d) children)) (fl : folder children) - : pattern (childrenInternal parentI (map fst children)) (parent * $(map snd children)) = +fun childrenG [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}] [t ::: Type] + (ready : $(map (fn (i, d) => option d) children) -> option t) + (parent : pattern parentI parent) (children : $(map (fn (i, d) => pattern i d) children)) (fl : folder children) + : pattern (childrenInternal parentI (map fst children)) (parent * t) = {Initial = None, EnterTag = fn tinfo state => case state of @@ -74,34 +82,37 @@ | Some pstate => Some (Some (pstate, 1, @map0 [status] (fn [t ::_] => Initial) (@@Folder.mp [fst] [_] fl)))) | Some (pstate, depth, cstates) => - Some (Some (pstate, - depth+1, - @map2 [fn (i, d) => pattern i d] [fn (i, d) => status i] [fn (i, d) => status i] - (fn [p] (ch : pattern p.1 p.2) (cstate : status p.1) => - case cstate of - Initial => - (case ch.EnterTag tinfo ch.Initial of - None => Initial - | Some v => - case ch.Finished v of - None => Pending v - | _ => Matched v) - | Pending cstate => - (case ch.EnterTag tinfo cstate of - None => Initial - | Some v => - case ch.Finished v of - None => Pending v - | _ => Matched v) - | v => v) - fl children cstates)), + if depth = 0 then + case parent.EnterTag tinfo parent.Initial of + None => None + | Some pstate => Some (Some (pstate, 1, @map0 [status] (fn [t ::_] => Initial) + (@@Folder.mp [fst] [_] fl))) + else + Some (Some (pstate, + depth+1, + @map2 [fn (i, d) => pattern i d] [fn (i, d) => status i] [fn (i, d) => status i] + (fn [p] (ch : pattern p.1 p.2) (cstate : status p.1) => + case cstate of + Initial => + (case ch.EnterTag tinfo ch.Initial of + None => Initial + | Some v => + case ch.Finished v of + None => Pending v + | _ => Matched v) + | Pending cstate => + (case ch.EnterTag tinfo cstate of + None => Initial + | Some v => + case ch.Finished v of + None => Pending v + | _ => Matched v) + | v => v) + fl children cstates)), ExitTag = fn state => case state of None => None - | Some (pstate, 1, cstates) => - (case parent.ExitTag pstate of - None => None - | Some pstate => Some (Some (pstate, 0, cstates))) + | Some (pstate, 1, cstates) => Some (Some (pstate, 0, cstates)) | Some (pstate, depth, cstates) => Some (Some (pstate, depth-1, @map2 [fn (i, d) => pattern i d] [fn (i, d) => status i] [fn (i, d) => status i] @@ -118,26 +129,34 @@ fl children cstates)), Finished = fn state => case state of - Some (pstate, _, cstates) => + Some (pstate, 0, cstates) => (case parent.Finished pstate of None => None | Some (pdata, pcont) => - case @foldR2 [fn (i, d) => pattern i d] [fn (i, d) => status i] [fn cs => option $(map snd cs)] - (fn [nm ::_] [p ::_] [r ::_] [[nm] ~ r] (ch : pattern p.1 p.2) (cstate : status p.1) acc => - case acc of - None => None - | Some acc => - case cstate of - Matched cstate => - (case ch.Finished cstate of - None => None - | Some (cdata, _) => Some ({nm = cdata} ++ acc)) - | _ => None) - (Some {}) fl children cstates of + case ready (@map2 [fn (i, d) => status i] [fn (i, d) => pattern i d] [fn (i, d) => option d] + (fn [p] (cstate : status p.1) (ch : pattern p.1 p.2) => + case cstate of + Matched v => Option.mp (fn p => p.1) (ch.Finished v) + | _ => None) fl cstates children) of None => None | Some cdata => Some ((pdata, cdata), pcont)) | _ => None} +fun children [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}] + (parent : pattern parentI parent) (children : $(map (fn (i, d) => pattern i d) children)) (fl : folder children) + : pattern (childrenInternal parentI (map fst children)) (parent * $(map snd children)) = + @childrenG (@foldR [fn (i, d) => option d] [fn cs => option $(map snd cs)] + (fn [nm ::_] [p ::_] [r ::_] [[nm] ~ r] (cstate : option p.2) acc => + case (cstate, acc) of + (Some cstate, Some acc) => Some ({nm = cstate} ++ acc) + | _ => None) + (Some {}) fl) parent children fl + +fun childrenO [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}] + (parent : pattern parentI parent) (children : $(map (fn (i, d) => pattern i d) children)) (fl : folder children) + : pattern (childrenInternal parentI (map fst children)) (parent * $(map (fn (i, d) => option d) children)) = + @childrenG Some parent children fl + con treeInternal (parent :: Type) (child :: Type) = option (parent * int * option child) fun tree [parentI ::: Type] [parent ::: Type] [childI ::: Type] [child ::: Type] @@ -157,10 +176,7 @@ ExitTag = fn state => case state of None => None - | Some (pstate, 1, cstate) => - (case parent.ExitTag pstate of - None => None - | Some pstate => Some (Some (pstate, 0, cstate))) + | Some (_, 1, _) => None | Some (pstate, depth, cstate) => Some (Some (pstate, depth-1, Option.bind child.ExitTag cstate)), Finished = fn state => @@ -249,10 +265,10 @@ case String.split xml #"=" of None => (xml, acc, False) | Some (aname, xml) => - if xml = "" || String.sub xml 0 <> #"\"" then + if xml = "" || (String.sub xml 0 <> #"\"" && String.sub xml 0 <> #"'") then (xml, (aname, "") :: acc, False) else - case String.split (String.suffix xml 1) #"\"" of + case String.split (String.suffix xml 1) (String.sub xml 0) of None => (xml, (aname, "") :: acc, False) | Some (value, xml) => if xml = "" then
--- a/src/ur/feed.urs Thu Jan 13 10:02:37 2011 -0500 +++ b/src/ur/feed.urs Sat Jan 15 15:25:22 2011 -0500 @@ -9,6 +9,9 @@ val tagA : attrs ::: {Unit} -> folder attrs -> string -> $(mapU string attrs) -> pattern (tagInternal attrs) $(mapU string attrs) +val tagAO : attrs ::: {Unit} -> folder attrs -> string -> $(mapU string attrs) + -> pattern (tagInternal attrs) $(mapU (option string) attrs) + val tagC : string -> pattern (tagInternal []) string con childrenInternal :: Type -> {Type} -> Type @@ -16,6 +19,9 @@ val children : parentI ::: Type -> parent ::: Type -> children ::: {(Type * Type)} -> pattern parentI parent -> $(map (fn (i, d) => pattern i d) children) -> folder children -> pattern (childrenInternal parentI (map fst children)) (parent * $(map snd children)) +val childrenO : parentI ::: Type -> parent ::: Type -> children ::: {(Type * Type)} + -> pattern parentI parent -> $(map (fn (i, d) => pattern i d) children) -> folder children + -> pattern (childrenInternal parentI (map fst children)) (parent * $(map (fn (i, d) => option d) children)) con treeInternal :: Type -> Type -> Type