changeset 21:7275f59cab61

tagAOR and a Reddit example of using it
author Adam Chlipala <adam@chlipala.net>
date Sat, 29 Sep 2012 10:30:00 -0400
parents dd5b333a7960
children 923e097e9ba3
files src/ur/feed.ur src/ur/feed.urs tests/reddit.ur tests/reddit.urp tests/reddit.urs
diffstat 5 files changed, 51 insertions(+), 1 deletions(-) [+]
line wrap: on
line diff
--- a/src/ur/feed.ur	Sat Jun 23 09:58:31 2012 -0400
+++ b/src/ur/feed.ur	Sat Sep 29 10:30:00 2012 -0400
@@ -80,7 +80,17 @@
 
 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
+    @tagG fl (fn r => Some r.Attrs) name attrs
+
+fun tagAOR [optional ::: {Unit}] [required ::: {Unit}] [optional ~ required]
+           (ofl : folder optional) (rfl : folder required)
+           (name : string) (required : $(mapU string required)) (optional : $(mapU string optional))
+    : pattern (tagInternal (optional ++ required)) $(mapU string required ++ mapU (option string) optional) =
+    @tagG (@Folder.concat ! ofl rfl)
+     (fn r => case @allPresent rfl (r.Attrs --- mapU (option string) optional) of
+                  None => None
+                | Some req => Some (r.Attrs --- mapU (option string) required ++ req))
+     name (required ++ optional)
 
 fun tagC (name : string) : pattern (tagInternal []) string =
     tagG (fn r => r.Cdata) name {}
--- a/src/ur/feed.urs	Sat Jun 23 09:58:31 2012 -0400
+++ b/src/ur/feed.urs	Sat Sep 29 10:30:00 2012 -0400
@@ -35,6 +35,13 @@
             -> pattern (tagInternal attrs) $(mapU (option string) attrs)
 (* A version of [tagA] that makes each attribute optional *)
 
+val tagAOR : optional ::: {Unit} -> required ::: {Unit} -> [optional ~ required]
+             => folder optional -> folder required -> string
+             -> $(mapU string required) -> $(mapU string optional)
+             -> pattern (tagInternal (optional ++ required))
+                        $(mapU string required ++ mapU (option string) optional)
+(* A version of [tagAO] that does a check for mere presence of other attributes *)
+
 val tagC : string -> pattern (tagInternal []) string
 (* A version of [tag] that only matches tags with nonempty CDATA and returns
  * only that text *)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/reddit.ur	Sat Sep 29 10:30:00 2012 -0400
@@ -0,0 +1,27 @@
+fun main () =
+    doc <- Feed.fetch "http://www.reddit.com/?limit=30";
+
+    acc <- Feed.app' (Feed.tree (Feed.tagAOR "div" {DataUps = "data-ups", Class = "class"} {Style = "style"})
+                                (Feed.tagAO "a" {Class = "class", Style = "style", Href = "href"}))
+           (fn (div, a) (count, list) =>
+               return (case a.Href of
+                           None => (count, list)
+                         | Some link =>
+                           if count >= 30
+                              || not (String.isPrefix {Full = div.Class, Prefix = " thing "})
+                              || Option.isSome (String.sindex {Haystack = div.Class, Needle = "promoted"})
+                              || div.Style = Some "display:none"
+                              || a.Class <> Some "title "
+                              || a.Style = Some "display:none" then
+                               (count, list)
+                           else
+                               (count + 1, link :: list)))
+           doc (0, []);
+
+    return <xml><body>
+      <h1>Top 30 Reddit Links</h1>
+
+      <ol>
+        {List.mapX (fn url => <xml><li>{[url]}</li></xml>) (List.rev acc.2)}
+      </ol>
+    </body></xml>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/reddit.urp	Sat Sep 29 10:30:00 2012 -0400
@@ -0,0 +1,5 @@
+library ../src/ur/lib
+rewrite all Reddit/*
+
+$/list
+reddit
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/reddit.urs	Sat Sep 29 10:30:00 2012 -0400
@@ -0,0 +1,1 @@
+val main : unit -> transaction page