Mercurial > urweb

annotate lib/ur/top.ur @ 643:aa2290c32ce2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Avoid any JavaScript when pages don't need it; update demo prose
author Adam Chlipala <adamc@hcoop.net>
date Tue, 10 Mar 2009 10:44:26 -0400
parents 24fd1edfcaa3
children fcf0bd3d1667
rev   line source
adamc@623 1 (** Row folding *)
adamc@623 2
adamc@623 3 con folder = K ==> fn r :: {K} =>
adamc@623 4 tf :: ({K} -> Type)
adamc@623 5 -> (nm :: Name -> v :: K -> r :: {K} -> tf r
adamc@629 6 -> [[nm] ~ r] => tf ([nm = v] ++ r))
adamc@623 7 -> tf [] -> tf r
adamc@623 8
adamc@627 9 structure Folder = struct
adamc@631 10 fun fold K (r ::: {K}) (fl : folder r) = fl
adamc@631 11
adamc@627 12 fun nil K (tf :: {K} -> Type)
adamc@627 13 (f : nm :: Name -> v :: K -> r :: {K} -> tf r
adamc@629 14 -> [[nm] ~ r] => tf ([nm = v] ++ r))
adamc@627 15 (i : tf []) = i
adamc@627 16
adamc@627 17 fun cons K (r ::: {K}) (nm :: Name) (v :: K) [[nm] ~ r] (fold : folder r)
adamc@627 18 (tf :: {K} -> Type)
adamc@627 19 (f : nm :: Name -> v :: K -> r :: {K} -> tf r
adamc@629 20 -> [[nm] ~ r] => tf ([nm = v] ++ r))
adamc@629 21 (i : tf []) = f [nm] [v] [r] (fold [tf] f i) !
adamc@628 22
adamc@628 23 fun concat K (r1 ::: {K}) (r2 ::: {K}) [r1 ~ r2]
adamc@628 24 (f1 : folder r1) (f2 : folder r2)
adamc@628 25 (tf :: {K} -> Type)
adamc@628 26 (f : nm :: Name -> v :: K -> r :: {K} -> tf r
adamc@629 27 -> [[nm] ~ r] => tf ([nm = v] ++ r))
adamc@628 28 (i : tf []) =
adamc@629 29 f1 [fn r1' => [r1' ~ r2] => tf (r1' ++ r2)]
adamc@629 30 (fn (nm :: Name) (v :: K) (r1' :: {K}) (acc : [r1' ~ r2] => tf (r1' ++ r2))
adamc@628 31 [[nm] ~ r1'] [[nm = v] ++ r1' ~ r2] =>
adamc@629 32 f [nm] [v] [r1' ++ r2] acc !)
adamc@629 33 (fn [[] ~ r2] => f2 [tf] f i) !
adamc@630 34
adamc@630 35 fun mp K1 K2 (f ::: K1 -> K2) (r ::: {K1})
adamc@630 36 (fold : folder r)
adamc@630 37 (tf :: {K2} -> Type)
adamc@630 38 (f : nm :: Name -> v :: K2 -> r :: {K2} -> tf r
adamc@630 39 -> [[nm] ~ r] => tf ([nm = v] ++ r))
adamc@630 40 (i : tf []) =
adamc@630 41 fold [fn r => tf (map f r)]
adamc@630 42 (fn (nm :: Name) (v :: K1) (rest :: {K1}) (acc : tf (map f rest)) [[nm] ~ rest] =>
adamc@630 43 f [nm] [f v] [map f rest] acc !)
adamc@630 44 i
adamc@627 45 end
adamc@627 46
adamc@623 47
adamc@422 48 fun not b = if b then False else True
adamc@422 49
adamc@356 50 con idT (t :: Type) = t
adamc@356 51 con record (t :: {Type}) = $t
adamc@637 52 con fst = K1 ==> K2 ==> fn t :: (K1 * K2) => t.1
adamc@637 53 con snd = K1 ==> K2 ==> fn t :: (K1 * K2) => t.2
adamc@637 54 con fst3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.1
adamc@637 55 con snd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.2
adamc@637 56 con thd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.3
adamc@329 57
adamc@643 58 con mapU = K ==> fn f :: K => map (fn _ :: Unit => f)
adamc@445 59
adamc@339 60 con ex = fn tf :: (Type -> Type) =>
adamc@356 61 res ::: Type -> (choice :: Type -> tf choice -> res) -> res
adamc@339 62
adamc@339 63 fun ex (tf :: (Type -> Type)) (choice :: Type) (body : tf choice) : ex tf =
adamc@356 64 fn (res ::: Type) (f : choice :: Type -> tf choice -> res) =>
adamc@356 65 f [choice] body
adamc@339 66
adamc@356 67 fun compose (t1 ::: Type) (t2 ::: Type) (t3 ::: Type)
adamc@356 68 (f1 : t2 -> t3) (f2 : t1 -> t2) (x : t1) = f1 (f2 x)
adamc@325 69
adamc@564 70 fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (_ : show t) (v : t) =
adamc@564 71 cdata (show v)
adamc@328 72
adamc@411 73 fun foldUR (tf :: Type) (tr :: {Unit} -> Type)
adamc@411 74 (f : nm :: Name -> rest :: {Unit}
adamc@629 75 -> [[nm] ~ rest] =>
adamc@411 76 tf -> tr rest -> tr ([nm] ++ rest))
adamc@632 77 (i : tr []) (r :: {Unit}) (fold : folder r)=
adamc@643 78 fold [fn r :: {Unit} => $(mapU tf r) -> tr r]
adamc@623 79 (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc
adamc@623 80 [[nm] ~ rest] r =>
adamc@629 81 f [nm] [rest] ! r.nm (acc (r -- nm)))
adamc@623 82 (fn _ => i)
adamc@411 83
adamc@418 84 fun foldUR2 (tf1 :: Type) (tf2 :: Type) (tr :: {Unit} -> Type)
adamc@418 85 (f : nm :: Name -> rest :: {Unit}
adamc@629 86 -> [[nm] ~ rest] =>
adamc@418 87 tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest))
adamc@632 88 (i : tr []) (r :: {Unit}) (fold : folder r) =
adamc@643 89 fold [fn r :: {Unit} => $(mapU tf1 r) -> $(mapU tf2 r) -> tr r]
adamc@623 90 (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc
adamc@623 91 [[nm] ~ rest] r1 r2 =>
adamc@629 92 f [nm] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
adamc@623 93 (fn _ _ => i)
adamc@418 94
adamc@418 95 fun foldURX2 (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit})
adamc@418 96 (f : nm :: Name -> rest :: {Unit}
adamc@629 97 -> [[nm] ~ rest] =>
adamc@418 98 tf1 -> tf2 -> xml ctx [] []) =
adamc@418 99 foldUR2 [tf1] [tf2] [fn _ => xml ctx [] []]
adamc@418 100 (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] v1 v2 acc =>
adamc@629 101 <xml>{f [nm] [rest] ! v1 v2}{acc}</xml>)
adamc@418 102 <xml/>
adamc@418 103
adamc@623 104 fun foldR K (tf :: K -> Type) (tr :: {K} -> Type)
adamc@623 105 (f : nm :: Name -> t :: K -> rest :: {K}
adamc@629 106 -> [[nm] ~ rest] =>
adamc@356 107 tf t -> tr rest -> tr ([nm = t] ++ rest))
adamc@632 108 (i : tr []) (r :: {K}) (fold : folder r) =
adamc@623 109 fold [fn r :: {K} => $(map tf r) -> tr r]
adamc@623 110 (fn (nm :: Name) (t :: K) (rest :: {K}) (acc : _ -> tr rest)
adamc@356 111 [[nm] ~ rest] r =>
adamc@629 112 f [nm] [t] [rest] ! r.nm (acc (r -- nm)))
adamc@356 113 (fn _ => i)
adamc@336 114
adamc@623 115 fun foldR2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (tr :: {K} -> Type)
adamc@623 116 (f : nm :: Name -> t :: K -> rest :: {K}
adamc@629 117 -> [[nm] ~ rest] =>
adamc@367 118 tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
adamc@632 119 (i : tr []) (r :: {K}) (fold : folder r) =
adamc@623 120 fold [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> tr r]
adamc@623 121 (fn (nm :: Name) (t :: K) (rest :: {K})
adamc@623 122 (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
adamc@629 123 f [nm] [t] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
adamc@623 124 (fn _ _ => i)
adamc@332 125
adamc@623 126 fun foldRX K (tf :: K -> Type) (ctx :: {Unit})
adamc@623 127 (f : nm :: Name -> t :: K -> rest :: {K}
adamc@629 128 -> [[nm] ~ rest] =>
adamc@356 129 tf t -> xml ctx [] []) =
adamc@623 130 foldR [tf] [fn _ => xml ctx [] []]
adamc@623 131 (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest] r acc =>
adamc@629 132 <xml>{f [nm] [t] [rest] ! r}{acc}</xml>)
adamc@623 133 <xml/>
adamc@336 134
adamc@623 135 fun foldRX2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (ctx :: {Unit})
adamc@623 136 (f : nm :: Name -> t :: K -> rest :: {K}
adamc@629 137 -> [[nm] ~ rest] =>
adamc@356 138 tf1 t -> tf2 t -> xml ctx [] []) =
adamc@623 139 foldR2 [tf1] [tf2] [fn _ => xml ctx [] []]
adamc@623 140 (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest]
adamc@623 141 r1 r2 acc =>
adamc@629 142 <xml>{f [nm] [t] [rest] ! r1 r2}{acc}</xml>)
adamc@623 143 <xml/>
adamc@445 144
adamc@356 145 fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
adamc@632 146 [tables ~ exps] (q : sql_query tables exps)
adamc@621 147 (f : $(exps ++ map (fn fields :: {Type} => $fields) tables)
adamc@356 148 -> xml ctx [] []) =
adamc@356 149 query q
adamc@356 150 (fn fs acc => return <xml>{acc}{f fs}</xml>)
adamc@360 151 <xml/>
adamc@341 152
adamc@469 153 fun queryX' (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
adamc@632 154 [tables ~ exps] (q : sql_query tables exps)
adamc@621 155 (f : $(exps ++ map (fn fields :: {Type} => $fields) tables)
adamc@469 156 -> transaction (xml ctx [] [])) =
adamc@469 157 query q
adamc@469 158 (fn fs acc =>
adamc@469 159 r <- f fs;
adamc@469 160 return <xml>{acc}{r}</xml>)
adamc@469 161 <xml/>
adamc@469 162
adamc@356 163 fun oneOrNoRows (tables ::: {{Type}}) (exps ::: {Type})
adamc@629 164 [tables ~ exps]
adamc@629 165 (q : sql_query tables exps) =
adamc@356 166 query q
adamc@356 167 (fn fs _ => return (Some fs))
adamc@356 168 None
adamc@440 169
adamc@440 170 fun oneRow (tables ::: {{Type}}) (exps ::: {Type})
adamc@629 171 [tables ~ exps] (q : sql_query tables exps) =
adamc@440 172 o <- oneOrNoRows q;
adamc@440 173 return (case o of
adamc@440 174 None => error <xml>Query returned no rows</xml>
adamc@440 175 | Some r => r)
adamc@440 176
adamc@470 177 fun eqNullable (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type})
adamc@470 178 (t ::: Type) (_ : sql_injectable (option t))
adamc@470 179 (e1 : sql_exp tables agg exps (option t))
adamc@470 180 (e2 : sql_exp tables agg exps (option t)) =
adamc@471 181 (SQL ({e1} IS NULL AND {e2} IS NULL) OR {e1} = {e2})
adamc@470 182
adamc@470 183 fun eqNullable' (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type})
adamc@564 184 (t ::: Type) (_ : sql_injectable (option t))
adamc@470 185 (e1 : sql_exp tables agg exps (option t))
adamc@470 186 (e2 : option t) =
adamc@470 187 case e2 of
adamc@471 188 None => (SQL {e1} IS NULL)
adamc@564 189 | Some _ => sql_binary sql_eq e1 (sql_inject e2)