Mercurial > urweb

comparison lib/top.ur @ 356:383c72d11db8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Basis and Top syntax-highlight, indent, parse, and type-check
author Adam Chlipala <adamc@hcoop.net>
date Sun, 12 Oct 2008 12:21:54 -0400
parents b85e6ba56618
children c1e96b387115
comparison
equal deleted inserted replaced
355:fa2d25fe75ce 356:383c72d11db8
1 con idT = fn t :: Type => t 1 con idT (t :: Type) = t
2 con record = fn t :: {Type} => $t 2 con record (t :: {Type}) = $t
3 con fstTT = fn t :: (Type * Type) => t.1 3 con fstTT (t :: (Type * Type)) = t.1
4 con sndTT = fn t :: (Type * Type) => t.2 4 con sndTT (t :: (Type * Type)) = t.2
5 5
6 con mapTT (f :: Type -> Type) = fold (fn nm t acc => [nm] ~ acc => 6 con mapTT (f :: Type -> Type) = fold (fn nm t acc [[nm] ~ acc] =>
7 [nm = f t] ++ acc) [] 7 [nm = f t] ++ acc) []
8 8
9 con mapT2T (f :: (Type * Type) -> Type) = fold (fn nm t acc => [nm] ~ acc => 9 con mapT2T (f :: (Type * Type) -> Type) = fold (fn nm t acc [[nm] ~ acc] =>
10 [nm = f t] ++ acc) [] 10 [nm = f t] ++ acc) []
11 11
12 con ex = fn tf :: (Type -> Type) => 12 con ex = fn tf :: (Type -> Type) =>
13 res ::: Type -> (choice :: Type -> tf choice -> res) -> res 13 res ::: Type -> (choice :: Type -> tf choice -> res) -> res
14 14
15 fun ex (tf :: (Type -> Type)) (choice :: Type) (body : tf choice) : ex tf = 15 fun ex (tf :: (Type -> Type)) (choice :: Type) (body : tf choice) : ex tf =
16 fn (res ::: Type) (f : choice :: Type -> tf choice -> res) => 16 fn (res ::: Type) (f : choice :: Type -> tf choice -> res) =>
17 f [choice] body 17 f [choice] body
18 18
19 fun compose (t1 ::: Type) (t2 ::: Type) (t3 ::: Type) (f1 : t2 -> t3) (f2 : t1 -> t2) (x : t1) = f1 (f2 x) 19 fun compose (t1 ::: Type) (t2 ::: Type) (t3 ::: Type)
20 (f1 : t2 -> t3) (f2 : t1 -> t2) (x : t1) = f1 (f2 x)
20 21
21 fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (sh : show t) (v : t) = cdata (show sh v) 22 fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (sh : show t) (v : t) =
23 cdata (show sh v)
22 24
23 fun foldTR (tf :: Type -> Type) (tr :: {Type} -> Type) 25 fun foldTR (tf :: Type -> Type) (tr :: {Type} -> Type)
24 (f : nm :: Name -> t :: Type -> rest :: {Type} -> [nm] ~ rest 26 (f : nm :: Name -> t :: Type -> rest :: {Type}
25 => tf t -> tr rest -> tr ([nm = t] ++ rest)) 27 -> fn [[nm] ~ rest] =>
26 (i : tr []) = 28 tf t -> tr rest -> tr ([nm = t] ++ rest))
27 fold [fn r :: {Type} => $(mapTT tf r) -> tr r] 29 (i : tr []) =
28 (fn (nm :: Name) (t :: Type) (rest :: {Type}) (acc : _ -> tr rest) => 30 fold [fn r :: {Type} => $(mapTT tf r) -> tr r]
29 [[nm] ~ rest] => 31 (fn (nm :: Name) (t :: Type) (rest :: {Type}) (acc : _ -> tr rest)
30 fn r => f [nm] [t] [rest] r.nm (acc (r -- nm))) 32 [[nm] ~ rest] r =>
31 (fn _ => i) 33 f [nm] [t] [rest] r.nm (acc (r -- nm)))
34 (fn _ => i)
32 35
33 fun foldT2R (tf :: (Type * Type) -> Type) (tr :: {(Type * Type)} -> Type) 36 fun foldT2R (tf :: (Type * Type) -> Type) (tr :: {(Type * Type)} -> Type)
34 (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} -> [nm] ~ rest 37 (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
35 => tf t -> tr rest -> tr ([nm = t] ++ rest)) 38 -> fn [[nm] ~ rest] =>
39 tf t -> tr rest -> tr ([nm = t] ++ rest))
36 (i : tr []) = 40 (i : tr []) =
37 fold [fn r :: {(Type * Type)} => $(mapT2T tf r) -> tr r] 41 fold [fn r :: {(Type * Type)} => $(mapT2T tf r) -> tr r]
38 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) (acc : _ -> tr rest) => 42 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
39 [[nm] ~ rest] => 43 (acc : _ -> tr rest) [[nm] ~ rest] r =>
40 fn r => f [nm] [t] [rest] r.nm (acc (r -- nm))) 44 f [nm] [t] [rest] r.nm (acc (r -- nm)))
41 (fn _ => i) 45 (fn _ => i)
42 46
43 fun foldTR2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (tr :: {Type} -> Type) 47 fun foldTR2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (tr :: {Type} -> Type)
44 (f : nm :: Name -> t :: Type -> rest :: {Type} -> [nm] ~ rest 48 (f : nm :: Name -> t :: Type -> rest :: {Type}
45 => tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) 49 -> fn [[nm] ~ rest] =>
50 tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
46 (i : tr []) = 51 (i : tr []) =
47 fold [fn r :: {Type} => $(mapTT tf1 r) -> $(mapTT tf2 r) -> tr r] 52 fold [fn r :: {Type} => $(mapTT tf1 r) -> $(mapTT tf2 r) -> tr r]
48 (fn (nm :: Name) (t :: Type) (rest :: {Type}) (acc : _ -> _ -> tr rest) => 53 (fn (nm :: Name) (t :: Type) (rest :: {Type})
49 [[nm] ~ rest] => 54 (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
50 fn r1 r2 => f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) 55 f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
51 (fn _ _ => i) 56 (fn _ _ => i)
52 57
53 fun foldT2R2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type) (tr :: {(Type * Type)} -> Type) 58 fun foldT2R2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type)
54 (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} -> [nm] ~ rest 59 (tr :: {(Type * Type)} -> Type)
55 => tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) 60 (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
56 (i : tr []) = 61 -> fn [[nm] ~ rest] =>
57 fold [fn r :: {(Type * Type)} => $(mapT2T tf1 r) -> $(mapT2T tf2 r) -> tr r] 62 tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
58 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) (acc : _ -> _ -> tr rest) => 63 (i : tr []) =
59 [[nm] ~ rest] => 64 fold [fn r :: {(Type * Type)} => $(mapT2T tf1 r) -> $(mapT2T tf2 r) -> tr r]
60 fn r1 r2 => f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) 65 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
61 (fn _ _ => i) 66 (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
67 f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
68 (fn _ _ => i)
62 69
63 fun foldTRX (tf :: Type -> Type) (ctx :: {Unit}) 70 fun foldTRX (tf :: Type -> Type) (ctx :: {Unit})
64 (f : nm :: Name -> t :: Type -> rest :: {Type} -> [nm] ~ rest 71 (f : nm :: Name -> t :: Type -> rest :: {Type}
65 => tf t -> xml ctx [] []) = 72 -> fn [[nm] ~ rest] =>
66 foldTR [tf] [fn _ => xml ctx [] []] 73 tf t -> xml ctx [] []) =
67 (fn (nm :: Name) (t :: Type) (rest :: {Type}) => 74 foldTR [tf] [fn _ => xml ctx [] []]
68 [[nm] ~ rest] => 75 (fn (nm :: Name) (t :: Type) (rest :: {Type}) [[nm] ~ rest] r acc =>
69 fn r acc => <xml>{f [nm] [t] [rest] r}{acc}</xml>) 76 <xml>{f [nm] [t] [rest] r}{acc}</xml>)
70 <xml></xml> 77 <xml></xml>
71 78
72 fun foldT2RX (tf :: (Type * Type) -> Type) (ctx :: {Unit}) 79 fun foldT2RX (tf :: (Type * Type) -> Type) (ctx :: {Unit})
73 (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} -> [nm] ~ rest 80 (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
74 => tf t -> xml ctx [] []) = 81 -> fn [[nm] ~ rest] =>
75 foldT2R [tf] [fn _ => xml ctx [] []] 82 tf t -> xml ctx [] []) =
76 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) => 83 foldT2R [tf] [fn _ => xml ctx [] []]
77 [[nm] ~ rest] => 84 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
78 fn r acc => <xml>{f [nm] [t] [rest] r}{acc}</xml>) 85 [[nm] ~ rest] r acc =>
79 <xml></xml> 86 <xml>{f [nm] [t] [rest] r}{acc}</xml>)
87 <xml></xml>
80 88
81 fun foldTRX2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (ctx :: {Unit}) 89 fun foldTRX2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (ctx :: {Unit})
82 (f : nm :: Name -> t :: Type -> rest :: {Type} -> [nm] ~ rest 90 (f : nm :: Name -> t :: Type -> rest :: {Type}
83 => tf1 t -> tf2 t -> xml ctx [] []) = 91 -> fn [[nm] ~ rest] =>
84 foldTR2 [tf1] [tf2] [fn _ => xml ctx [] []] 92 tf1 t -> tf2 t -> xml ctx [] []) =
85 (fn (nm :: Name) (t :: Type) (rest :: {Type}) => 93 foldTR2 [tf1] [tf2] [fn _ => xml ctx [] []]
86 [[nm] ~ rest] => 94 (fn (nm :: Name) (t :: Type) (rest :: {Type}) [[nm] ~ rest]
87 fn r1 r2 acc => <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>) 95 r1 r2 acc =>
88 <xml></xml> 96 <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>)
97 <xml></xml>
89 98
90 fun foldT2RX2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type) (ctx :: {Unit}) 99 fun foldT2RX2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type)
91 (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)} -> [nm] ~ rest 100 (ctx :: {Unit})
92 => tf1 t -> tf2 t -> xml ctx [] []) = 101 (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
93 foldT2R2 [tf1] [tf2] [fn _ => xml ctx [] []] 102 -> fn [[nm] ~ rest] =>
94 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) => 103 tf1 t -> tf2 t -> xml ctx [] []) =
95 [[nm] ~ rest] => 104 foldT2R2 [tf1] [tf2] [fn _ => xml ctx [] []]
96 fn r1 r2 acc => <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>) 105 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
97 <xml></xml> 106 [[nm] ~ rest] r1 r2 acc =>
107 <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>)
108 <xml></xml>
98 109
99 fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) (q : sql_query tables exps) = 110 fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
100 [tables ~ exps] => 111 (q : sql_query tables exps) [tables ~ exps]
101 fn (f : $(exps ++ fold (fn nm (fields :: {Type}) acc => [nm] ~ acc => [nm = $fields] ++ acc) [] tables) 112 (f : $(exps ++ fold (fn nm (fields :: {Type}) acc [[nm] ~ acc] =>
102 -> xml ctx [] []) => 113 [nm = $fields] ++ acc) [] tables)
103 query q 114 -> xml ctx [] []) =
104 (fn fs acc => return <xml>{acc}{f fs}</xml>) 115 query q
105 <xml></xml> 116 (fn fs acc => return <xml>{acc}{f fs}</xml>)
117 <xml></xml>
106 118
107 fun oneOrNoRows (tables ::: {{Type}}) (exps ::: {Type}) (q : sql_query tables exps) = 119 fun oneOrNoRows (tables ::: {{Type}}) (exps ::: {Type})
108 [tables ~ exps] => 120 (q : sql_query tables exps) [tables ~ exps] =
109 query q 121 query q
110 (fn fs _ => return (Some fs)) 122 (fn fs _ => return (Some fs))
111 None 123 None