Mercurial > urweb
annotate tests/tags.ur @ 2084:0d48cfb59b29
More aggressive inlining of 'let' with record literals, plus some changes to Monoization of queries, to make inlining more common
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Thu, 04 Dec 2014 02:47:24 -0500 |
| parents | 884673e5f7d5 |
| children |
| rev | line source |
|---|---|
| adam@2031 | 1 table images : { Id : int, Content : blob } |
| adam@2031 | 2 table tags : { Id : int, Tag : string } |
| adam@2031 | 3 |
| adam@2031 | 4 datatype mode = Present | Absent |
| adam@2031 | 5 type condition = { Tag : string, Mode : mode } |
| adam@2031 | 6 |
| adam@2031 | 7 type tag_query = sql_query [] [] [] [Id = int] |
| adam@2031 | 8 |
| adam@2031 | 9 fun addCondition (c : condition) (q : tag_query) : tag_query = |
| adam@2031 | 10 case c.Mode of |
| adam@2031 | 11 Present => (SELECT I.Id AS Id |
| adam@2031 | 12 FROM ({{q}}) AS I |
| adam@2031 | 13 JOIN tags ON tags.Id = I.Id AND tags.Tag = {[c.Tag]}) |
| adam@2032 | 14 | Absent => (SELECT I.Id AS Id |
| adam@2032 | 15 FROM ({{q}}) AS I |
| adam@2032 | 16 LEFT JOIN tags ON tags.Id = I.Id AND tags.Tag = {[c.Tag]} |
| adam@2032 | 17 WHERE tags.Tag IS NULL) |
| adam@2031 | 18 |
| adam@2031 | 19 fun withConditions (cs : list condition) : tag_query = |
| adam@2031 | 20 List.foldl addCondition (SELECT images.Id AS Id FROM images) cs |
| adam@2031 | 21 |
| adam@2031 | 22 fun main (cs : list condition) : transaction page = |
| adam@2031 | 23 x <- queryX (withConditions cs) (fn r => <xml><li>{[r.Id]}</li></xml>); |
| adam@2031 | 24 return <xml><body> |
| adam@2031 | 25 {x} |
| adam@2031 | 26 </body></xml> |