Mercurial > feed

comparison src/ur/feed.ur @ 6:e0bae488825c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
'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
comparison
equal deleted inserted replaced
5:2717458d8951 6:e0bae488825c
9 {Initial = (), 9 {Initial = (),
10 EnterTag = fn _ () => Some (), 10 EnterTag = fn _ () => Some (),
11 ExitTag = fn () => Some (), 11 ExitTag = fn () => Some (),
12 Finished = fn () => None} 12 Finished = fn () => None}
13 13
14 con tagInternal (attrs :: {Unit}) = option {Attrs : $(mapU string attrs), Cdata : option string} 14 con tagInternal (attrs :: {Unit}) = option {Attrs : $(mapU (option string) attrs), Cdata : option string}
15 15
16 fun tagG [attrs ::: {Unit}] [t ::: Type] (fl : folder attrs) (accept : {Attrs : $(mapU string attrs), Cdata : option string} -> option t) 16 fun tagG [attrs ::: {Unit}] [t ::: Type] (fl : folder attrs) (accept : {Attrs : $(mapU (option string) attrs), Cdata : option string} -> option t)
17 (name : string) (attrs : $(mapU string attrs)) 17 (name : string) (attrs : $(mapU string attrs))
18 : pattern (tagInternal attrs) t = 18 : pattern (tagInternal attrs) t =
19 {Initial = None, 19 {Initial = None,
20 EnterTag = fn tinfo _ => 20 EnterTag = fn tinfo _ =>
21 if tinfo.Tag <> name then 21 if tinfo.Tag <> name then
22 None 22 None
23 else 23 else
24 case @foldUR [string] [fn r => option $(mapU string r)] 24 let
25 (fn [nm ::_] [r ::_] [[nm] ~ r] aname ro => 25 val v = {Attrs = @mp [fn _ => string] [fn _ => option string]
26 case ro of 26 (fn [u] aname => List.assoc aname tinfo.Attrs)
27 None => None 27 fl attrs,
28 | Some r => 28 Cdata = tinfo.Cdata}
29 case List.assoc aname tinfo.Attrs of 29 in
30 None => None 30 case accept v of
31 | Some v => Some ({nm = v} ++ r)) 31 None => None
32 (Some {}) fl attrs of 32 | Some _ => Some (Some v)
33 None => None 33 end,
34 | Some vs =>
35 let
36 val v = {Attrs = vs, Cdata = tinfo.Cdata}
37 in
38 case accept v of
39 None => None
40 | Some _ => Some (Some v)
41 end,
42 ExitTag = fn _ => None, 34 ExitTag = fn _ => None,
43 Finished = fn state => case state of 35 Finished = fn state => case state of
44 None => None 36 None => None
45 | Some state => 37 | Some state =>
46 case accept state of 38 case accept state of
47 None => None 39 None => None
48 | Some v => Some (v, False)} 40 | Some v => Some (v, False)}
49 41
42 fun allPresent [attrs ::: {Unit}] (fl : folder attrs) (attrs : $(mapU (option string) attrs)) : option $(mapU string attrs) =
43 @foldUR [option string] [fn attrs => option $(mapU string attrs)]
44 (fn [nm ::_] [r ::_] [[nm] ~ r] os acc =>
45 case (os, acc) of
46 (Some s, Some acc) => Some ({nm = s} ++ acc)
47 | _ => None)
48 (Some {}) fl attrs
49
50 fun tag [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU string attrs)) 50 fun tag [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU string attrs))
51 : pattern (tagInternal attrs) {Attrs : $(mapU string attrs), Cdata : option string} = 51 : pattern (tagInternal attrs) {Attrs : $(mapU string attrs), Cdata : option string} =
52 @tagG fl Some name attrs 52 @tagG fl (fn r =>
53 case @allPresent fl r.Attrs of
54 None => None
55 | Some attrs => Some (r -- #Attrs ++ {Attrs = attrs}))
56 name attrs
53 57
54 fun tagA [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU string attrs)) 58 fun tagA [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU string attrs))
55 : pattern (tagInternal attrs) $(mapU string attrs) = 59 : pattern (tagInternal attrs) $(mapU string attrs) =
56 @tagG fl (fn r => Some r.Attrs) name attrs 60 @tagG fl (fn r => @allPresent fl r.Attrs) name attrs
61 fun tagAO [attrs ::: {Unit}] (fl : folder attrs) (name : string) (attrs : $(mapU string attrs))
62 : pattern (tagInternal attrs) $(mapU (option string) attrs) =
63 @tagG fl (fn r => Some (r.Attrs)) name attrs
57 64
58 fun tagC (name : string) : pattern (tagInternal []) string = 65 fun tagC (name : string) : pattern (tagInternal []) string =
59 tagG (fn r => r.Cdata) name {} 66 tagG (fn r => r.Cdata) name {}
60 67
61 datatype status a = Initial | Pending of a | Matched of a 68 datatype status a = Initial | Pending of a | Matched of a
62 69
63 con childrenInternal (parent :: Type) (children :: {Type}) = option (parent * int * $(map status children)) 70 con childrenInternal (parent :: Type) (children :: {Type}) = option (parent * int * $(map status children))
64 71
65 fun children [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}] 72 fun childrenG [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}] [t ::: Type]
66 (parent : pattern parentI parent) (children : $(map (fn (i, d) => pattern i d) children)) (fl : folder children) 73 (ready : $(map (fn (i, d) => option d) children) -> option t)
67 : pattern (childrenInternal parentI (map fst children)) (parent * $(map snd children)) = 74 (parent : pattern parentI parent) (children : $(map (fn (i, d) => pattern i d) children)) (fl : folder children)
75 : pattern (childrenInternal parentI (map fst children)) (parent * t) =
68 {Initial = None, 76 {Initial = None,
69 EnterTag = fn tinfo state => 77 EnterTag = fn tinfo state =>
70 case state of 78 case state of
71 None => 79 None =>
72 (case parent.EnterTag tinfo parent.Initial of 80 (case parent.EnterTag tinfo parent.Initial of
73 None => None 81 None => None
74 | Some pstate => Some (Some (pstate, 1, @map0 [status] (fn [t ::_] => Initial) 82 | Some pstate => Some (Some (pstate, 1, @map0 [status] (fn [t ::_] => Initial)
75 (@@Folder.mp [fst] [_] fl)))) 83 (@@Folder.mp [fst] [_] fl))))
76 | Some (pstate, depth, cstates) => 84 | Some (pstate, depth, cstates) =>
77 Some (Some (pstate, 85 if depth = 0 then
78 depth+1, 86 case parent.EnterTag tinfo parent.Initial of
79 @map2 [fn (i, d) => pattern i d] [fn (i, d) => status i] [fn (i, d) => status i] 87 None => None
80 (fn [p] (ch : pattern p.1 p.2) (cstate : status p.1) => 88 | Some pstate => Some (Some (pstate, 1, @map0 [status] (fn [t ::_] => Initial)
81 case cstate of 89 (@@Folder.mp [fst] [_] fl)))
82 Initial => 90 else
83 (case ch.EnterTag tinfo ch.Initial of 91 Some (Some (pstate,
84 None => Initial 92 depth+1,
85 | Some v => 93 @map2 [fn (i, d) => pattern i d] [fn (i, d) => status i] [fn (i, d) => status i]
86 case ch.Finished v of 94 (fn [p] (ch : pattern p.1 p.2) (cstate : status p.1) =>
87 None => Pending v 95 case cstate of
88 | _ => Matched v) 96 Initial =>
89 | Pending cstate => 97 (case ch.EnterTag tinfo ch.Initial of
90 (case ch.EnterTag tinfo cstate of 98 None => Initial
91 None => Initial 99 | Some v =>
92 | Some v => 100 case ch.Finished v of
93 case ch.Finished v of 101 None => Pending v
94 None => Pending v 102 | _ => Matched v)
95 | _ => Matched v) 103 | Pending cstate =>
96 | v => v) 104 (case ch.EnterTag tinfo cstate of
97 fl children cstates)), 105 None => Initial
106 | Some v =>
107 case ch.Finished v of
108 None => Pending v
109 | _ => Matched v)
110 | v => v)
111 fl children cstates)),
98 ExitTag = fn state => 112 ExitTag = fn state =>
99 case state of 113 case state of
100 None => None 114 None => None
101 | Some (pstate, 1, cstates) => 115 | Some (pstate, 1, cstates) => Some (Some (pstate, 0, cstates))
102 (case parent.ExitTag pstate of
103 None => None
104 | Some pstate => Some (Some (pstate, 0, cstates)))
105 | Some (pstate, depth, cstates) => 116 | Some (pstate, depth, cstates) =>
106 Some (Some (pstate, depth-1, 117 Some (Some (pstate, depth-1,
107 @map2 [fn (i, d) => pattern i d] [fn (i, d) => status i] [fn (i, d) => status i] 118 @map2 [fn (i, d) => pattern i d] [fn (i, d) => status i] [fn (i, d) => status i]
108 (fn [p] (ch : pattern p.1 p.2) (cstate : status p.1) => 119 (fn [p] (ch : pattern p.1 p.2) (cstate : status p.1) =>
109 case cstate of 120 case cstate of
116 | _ => Matched cstate') 127 | _ => Matched cstate')
117 | _ => cstate) 128 | _ => cstate)
118 fl children cstates)), 129 fl children cstates)),
119 Finished = fn state => 130 Finished = fn state =>
120 case state of 131 case state of
121 Some (pstate, _, cstates) => 132 Some (pstate, 0, cstates) =>
122 (case parent.Finished pstate of 133 (case parent.Finished pstate of
123 None => None 134 None => None
124 | Some (pdata, pcont) => 135 | Some (pdata, pcont) =>
125 case @foldR2 [fn (i, d) => pattern i d] [fn (i, d) => status i] [fn cs => option $(map snd cs)] 136 case ready (@map2 [fn (i, d) => status i] [fn (i, d) => pattern i d] [fn (i, d) => option d]
126 (fn [nm ::_] [p ::_] [r ::_] [[nm] ~ r] (ch : pattern p.1 p.2) (cstate : status p.1) acc => 137 (fn [p] (cstate : status p.1) (ch : pattern p.1 p.2) =>
127 case acc of 138 case cstate of
128 None => None 139 Matched v => Option.mp (fn p => p.1) (ch.Finished v)
129 | Some acc => 140 | _ => None) fl cstates children) of
130 case cstate of
131 Matched cstate =>
132 (case ch.Finished cstate of
133 None => None
134 | Some (cdata, _) => Some ({nm = cdata} ++ acc))
135 | _ => None)
136 (Some {}) fl children cstates of
137 None => None 141 None => None
138 | Some cdata => Some ((pdata, cdata), pcont)) 142 | Some cdata => Some ((pdata, cdata), pcont))
139 | _ => None} 143 | _ => None}
144
145 fun children [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}]
146 (parent : pattern parentI parent) (children : $(map (fn (i, d) => pattern i d) children)) (fl : folder children)
147 : pattern (childrenInternal parentI (map fst children)) (parent * $(map snd children)) =
148 @childrenG (@foldR [fn (i, d) => option d] [fn cs => option $(map snd cs)]
149 (fn [nm ::_] [p ::_] [r ::_] [[nm] ~ r] (cstate : option p.2) acc =>
150 case (cstate, acc) of
151 (Some cstate, Some acc) => Some ({nm = cstate} ++ acc)
152 | _ => None)
153 (Some {}) fl) parent children fl
154
155 fun childrenO [parentI ::: Type] [parent ::: Type] [children ::: {(Type * Type)}]
156 (parent : pattern parentI parent) (children : $(map (fn (i, d) => pattern i d) children)) (fl : folder children)
157 : pattern (childrenInternal parentI (map fst children)) (parent * $(map (fn (i, d) => option d) children)) =
158 @childrenG Some parent children fl
140 159
141 con treeInternal (parent :: Type) (child :: Type) = option (parent * int * option child) 160 con treeInternal (parent :: Type) (child :: Type) = option (parent * int * option child)
142 161
143 fun tree [parentI ::: Type] [parent ::: Type] [childI ::: Type] [child ::: Type] 162 fun tree [parentI ::: Type] [parent ::: Type] [childI ::: Type] [child ::: Type]
144 (parent : pattern parentI parent) (child : pattern childI child) 163 (parent : pattern parentI parent) (child : pattern childI child)
155 depth+1, 174 depth+1,
156 child.EnterTag tinfo (Option.get child.Initial cstate))), 175 child.EnterTag tinfo (Option.get child.Initial cstate))),
157 ExitTag = fn state => 176 ExitTag = fn state =>
158 case state of 177 case state of
159 None => None 178 None => None
160 | Some (pstate, 1, cstate) => 179 | Some (_, 1, _) => None
161 (case parent.ExitTag pstate of
162 None => None
163 | Some pstate => Some (Some (pstate, 0, cstate)))
164 | Some (pstate, depth, cstate) => 180 | Some (pstate, depth, cstate) =>
165 Some (Some (pstate, depth-1, Option.bind child.ExitTag cstate)), 181 Some (Some (pstate, depth-1, Option.bind child.ExitTag cstate)),
166 Finished = fn state => 182 Finished = fn state =>
167 case state of 183 case state of
168 None => None 184 None => None
247 | Some xml => (xml, acc, True)) 263 | Some xml => (xml, acc, True))
248 else 264 else
249 case String.split xml #"=" of 265 case String.split xml #"=" of
250 None => (xml, acc, False) 266 None => (xml, acc, False)
251 | Some (aname, xml) => 267 | Some (aname, xml) =>
252 if xml = "" || String.sub xml 0 <> #"\"" then 268 if xml = "" || (String.sub xml 0 <> #"\"" && String.sub xml 0 <> #"'") then
253 (xml, (aname, "") :: acc, False) 269 (xml, (aname, "") :: acc, False)
254 else 270 else
255 case String.split (String.suffix xml 1) #"\"" of 271 case String.split (String.suffix xml 1) (String.sub xml 0) of
256 None => (xml, (aname, "") :: acc, False) 272 None => (xml, (aname, "") :: acc, False)
257 | Some (value, xml) => 273 | Some (value, xml) =>
258 if xml = "" then 274 if xml = "" then
259 (xml, (aname, value) :: acc, False) 275 (xml, (aname, value) :: acc, False)
260 else 276 else