adamc@623: (** Row folding *) adamc@623: adamc@623: con folder = K ==> fn r :: {K} => adamc@623: tf :: ({K} -> Type) adamc@653: -> (nm :: Name -> v :: K -> r :: {K} -> [[nm] ~ r] => adamc@653: tf r -> tf ([nm = v] ++ r)) adamc@623: -> tf [] -> tf r adamc@623: adamc@822: fun fold [K] [tf :: {K} -> Type] adamc@653: (f : (nm :: Name -> v :: K -> r :: {K} -> [[nm] ~ r] => adamc@653: tf r -> tf ([nm = v] ++ r))) adamc@1093: (i : tf []) [r ::: {K}] (fl : folder r) = fl [tf] f i adamc@653: adamc@627: structure Folder = struct adamc@822: fun nil [K] [tf :: {K} -> Type] adamc@653: (f : nm :: Name -> v :: K -> r :: {K} -> [[nm] ~ r] => adamc@653: tf r -> tf ([nm = v] ++ r)) adamc@627: (i : tf []) = i adamc@627: adamc@822: fun cons [K] [r ::: {K}] [nm :: Name] [v :: K] [[nm] ~ r] (fold : folder r) adamc@822: [tf :: {K} -> Type] adamc@653: (f : nm :: Name -> v :: K -> r :: {K} -> [[nm] ~ r] => adamc@653: tf r -> tf ([nm = v] ++ r)) adam@1472: (i : tf []) = f [nm] [v] [r] (fold [tf] f i) adamc@628: adamc@822: fun concat [K] [r1 ::: {K}] [r2 ::: {K}] [r1 ~ r2] adamc@628: (f1 : folder r1) (f2 : folder r2) adamc@822: [tf :: {K} -> Type] adamc@653: (f : nm :: Name -> v :: K -> r :: {K} -> [[nm] ~ r] => adamc@653: tf r -> tf ([nm = v] ++ r)) adamc@628: (i : tf []) = adamc@629: f1 [fn r1' => [r1' ~ r2] => tf (r1' ++ r2)] adamc@822: (fn [nm :: Name] [v :: K] [r1' :: {K}] [[nm] ~ r1'] adamc@653: (acc : [r1' ~ r2] => tf (r1' ++ r2)) adamc@653: [[nm = v] ++ r1' ~ r2] => adam@1472: f [nm] [v] [r1' ++ r2] acc) adam@1472: (fn [[] ~ r2] => f2 [tf] f i) adamc@630: adamc@822: fun mp [K1] [K2] [f ::: K1 -> K2] [r ::: {K1}] adamc@630: (fold : folder r) adamc@822: [tf :: {K2} -> Type] adamc@653: (f : nm :: Name -> v :: K2 -> r :: {K2} -> [[nm] ~ r] => adamc@653: tf r -> tf ([nm = v] ++ r)) adamc@630: (i : tf []) = adamc@630: fold [fn r => tf (map f r)] adamc@822: (fn [nm :: Name] [v :: K1] [rest :: {K1}] [[nm] ~ rest] (acc : tf (map f rest)) => adam@1472: f [nm] [f v] [map f rest] acc) adamc@630: i adamc@627: end adamc@627: adamc@623: adamc@422: fun not b = if b then False else True adamc@422: adam@1649: con ident = K ==> fn t :: K => t adamc@356: con record (t :: {Type}) = $t adamc@637: con fst = K1 ==> K2 ==> fn t :: (K1 * K2) => t.1 adamc@637: con snd = K1 ==> K2 ==> fn t :: (K1 * K2) => t.2 adamc@637: con fst3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.1 adamc@637: con snd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.2 adamc@637: con thd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.3 adamc@329: adamc@643: con mapU = K ==> fn f :: K => map (fn _ :: Unit => f) adamc@445: adam@1434: con ex = K ==> fn tf :: (K -> Type) => adam@1434: res ::: Type -> (choice :: K -> tf choice -> res) -> res adamc@339: adam@1434: fun ex_intro [K] [tf :: K -> Type] [choice :: K] (body : tf choice) : ex tf = adam@1434: fn [res] (f : choice :: K -> tf choice -> res) => adamc@356: f [choice] body adamc@339: adam@1434: fun ex_elim [K] [tf ::: K -> Type] (v : ex tf) [res ::: Type] = @@v [res] adam@1434: adamc@822: fun compose [t1 ::: Type] [t2 ::: Type] [t3 ::: Type] adamc@356: (f1 : t2 -> t3) (f2 : t1 -> t2) (x : t1) = f1 (f2 x) adamc@325: adamc@822: fun show_option [t ::: Type] (_ : show t) = adamc@777: mkShow (fn opt : option t => adamc@777: case opt of adamc@777: None => "" adamc@777: | Some x => show x) adamc@777: adamc@822: fun read_option [t ::: Type] (_ : read t) = adamc@777: mkRead (fn s => adamc@777: case s of adamc@777: "" => None adamc@777: | _ => Some (readError s : t)) adamc@777: (fn s => adamc@777: case s of adamc@777: "" => Some None adamc@777: | _ => case read s of adamc@777: None => None adamc@777: | v => Some v) adamc@777: adam@1360: fun txt [t] [ctx ::: {Unit}] [use ::: {Type}] (_ : show t) (v : t) : xml ctx use [] = adamc@564: cdata (show v) adamc@328: adamc@1093: fun map0 [K] [tf :: K -> Type] (f : t :: K -> tf t) [r ::: {K}] (fl : folder r) = adamc@993: fl [fn r :: {K} => $(map tf r)] adamc@993: (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc => adamc@993: acc ++ {nm = f [t]}) adamc@993: {} adamc@993: adamc@1093: fun mp [K] [tf1 :: K -> Type] [tf2 :: K -> Type] (f : t ::: K -> tf1 t -> tf2 t) [r ::: {K}] (fl : folder r) = adamc@898: fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r)] adamc@898: (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc r => adamc@898: acc (r -- nm) ++ {nm = f r.nm}) adamc@898: (fn _ => {}) adamc@898: adamc@905: fun map2 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] adamc@1093: (f : t ::: K -> tf1 t -> tf2 t -> tf3 t) [r ::: {K}] (fl : folder r) = adamc@905: fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r)] adamc@905: (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc r1 r2 => adamc@905: acc (r1 -- nm) (r2 -- nm) ++ {nm = f r1.nm r2.nm}) adamc@905: (fn _ _ => {}) adamc@898: adamc@937: fun map3 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [tf :: K -> Type] adamc@1093: (f : t ::: K -> tf1 t -> tf2 t -> tf3 t -> tf t) [r ::: {K}] (fl : folder r) = adamc@937: fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> $(map tf r)] adamc@937: (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc r1 r2 r3 => adamc@937: acc (r1 -- nm) (r2 -- nm) (r3 -- nm) ++ {nm = f r1.nm r2.nm r3.nm}) adamc@937: (fn _ _ _ => {}) adamc@937: adamc@822: fun foldUR [tf :: Type] [tr :: {Unit} -> Type] adamc@411: (f : nm :: Name -> rest :: {Unit} adamc@629: -> [[nm] ~ rest] => adamc@411: tf -> tr rest -> tr ([nm] ++ rest)) adamc@1093: (i : tr []) [r ::: {Unit}] (fl : folder r) = adamc@653: fl [fn r :: {Unit} => $(mapU tf r) -> tr r] adamc@822: (fn [nm :: Name] [t :: Unit] [rest :: {Unit}] [[nm] ~ rest] acc r => adam@1472: f [nm] [rest] r.nm (acc (r -- nm))) adamc@653: (fn _ => i) adamc@411: adamc@822: fun foldUR2 [tf1 :: Type] [tf2 :: Type] [tr :: {Unit} -> Type] adamc@418: (f : nm :: Name -> rest :: {Unit} adamc@629: -> [[nm] ~ rest] => adamc@418: tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest)) adamc@1093: (i : tr []) [r ::: {Unit}] (fl : folder r) = adamc@653: fl [fn r :: {Unit} => $(mapU tf1 r) -> $(mapU tf2 r) -> tr r] adamc@822: (fn [nm :: Name] [t :: Unit] [rest :: {Unit}] [[nm] ~ rest] acc r1 r2 => adam@1472: f [nm] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) adamc@653: (fn _ _ => i) adamc@418: adamc@822: fun foldR [K] [tf :: K -> Type] [tr :: {K} -> Type] adamc@623: (f : nm :: Name -> t :: K -> rest :: {K} adamc@629: -> [[nm] ~ rest] => adamc@356: tf t -> tr rest -> tr ([nm = t] ++ rest)) adamc@1093: (i : tr []) [r ::: {K}] (fl : folder r) = adamc@653: fl [fn r :: {K} => $(map tf r) -> tr r] adamc@822: (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] (acc : _ -> tr rest) r => adam@1472: f [nm] [t] [rest] r.nm (acc (r -- nm))) adamc@653: (fn _ => i) adamc@336: adamc@822: fun foldR2 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tr :: {K} -> Type] adamc@623: (f : nm :: Name -> t :: K -> rest :: {K} adamc@629: -> [[nm] ~ rest] => adamc@367: tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) adamc@1093: (i : tr []) [r ::: {K}] (fl : folder r) = adamc@653: fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> tr r] adamc@822: (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] adamc@653: (acc : _ -> _ -> tr rest) r1 r2 => adam@1472: f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) adamc@653: (fn _ _ => i) adamc@332: adamc@910: fun foldR3 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [tr :: {K} -> Type] adamc@910: (f : nm :: Name -> t :: K -> rest :: {K} adamc@910: -> [[nm] ~ rest] => adamc@910: tf1 t -> tf2 t -> tf3 t -> tr rest -> tr ([nm = t] ++ rest)) adamc@1093: (i : tr []) [r ::: {K}] (fl : folder r) = adamc@910: fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> tr r] adamc@910: (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] adamc@910: (acc : _ -> _ -> _ -> tr rest) r1 r2 r3 => adam@1472: f [nm] [t] [rest] r1.nm r2.nm r3.nm (acc (r1 -- nm) (r2 -- nm) (r3 -- nm))) adamc@910: (fn _ _ _ => i) adamc@910: adamc@1172: fun mapUX [tf :: Type] [ctx :: {Unit}] adamc@1172: (f : nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] => tf -> xml ctx [] []) = adamc@1172: @@foldR [fn _ => tf] [fn _ => xml ctx [] []] adamc@1172: (fn [nm :: Name] [u :: Unit] [rest :: {Unit}] [[nm] ~ rest] r acc => adam@1472: {f [nm] [rest] r}{acc}) adamc@1172: adamc@1172: adamc@1172: fun mapX [K] [tf :: K -> Type] [ctx :: {Unit}] adamc@623: (f : nm :: Name -> t :: K -> rest :: {K} adamc@629: -> [[nm] ~ rest] => adamc@720: tf t -> xml ctx [] []) = adamc@1093: @@foldR [tf] [fn _ => xml ctx [] []] adamc@1093: (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] r acc => adam@1472: {f [nm] [t] [rest] r}{acc}) adamc@1093: adamc@336: adamc@1173: fun mapUX2 [tf1 :: Type] [tf2 :: Type] [ctx :: {Unit}] adamc@1173: (f : nm :: Name -> rest :: {Unit} adamc@1173: -> [[nm] ~ rest] => adamc@1173: tf1 -> tf2 -> xml ctx [] []) = adamc@1173: @@foldUR2 [tf1] [tf2] [fn _ => xml ctx [] []] adamc@1173: (fn [nm :: Name] [rest :: {Unit}] [[nm] ~ rest] v1 v2 acc => adam@1472: {f [nm] [rest] v1 v2}{acc}) adamc@1173: adamc@1173: adamc@1172: fun mapX2 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [ctx :: {Unit}] adamc@623: (f : nm :: Name -> t :: K -> rest :: {K} adamc@629: -> [[nm] ~ rest] => adamc@720: tf1 t -> tf2 t -> xml ctx [] []) = adamc@1093: @@foldR2 [tf1] [tf2] [fn _ => xml ctx [] []] adamc@1093: (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] adamc@1093: r1 r2 acc => adam@1472: {f [nm] [t] [rest] r1 r2}{acc}) adamc@1093: adamc@445: adamc@1172: fun mapX3 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [ctx :: {Unit}] adamc@910: (f : nm :: Name -> t :: K -> rest :: {K} adamc@910: -> [[nm] ~ rest] => adamc@910: tf1 t -> tf2 t -> tf3 t -> xml ctx [] []) = adamc@1093: @@foldR3 [tf1] [tf2] [tf3] [fn _ => xml ctx [] []] adamc@1093: (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] adamc@1093: r1 r2 r3 acc => adam@1472: {f [nm] [t] [rest] r1 r2 r3}{acc}) adamc@1093: adamc@910: adam@1394: fun query1 [t ::: Name] [fs ::: {Type}] [state ::: Type] (q : sql_query [] [] [t = fs] []) adamc@1177: (f : $fs -> state -> transaction state) (i : state) = adamc@1177: query q (fn r => f r.t) i adamc@1177: adam@1394: fun query1' [t ::: Name] [fs ::: {Type}] [state ::: Type] (q : sql_query [] [] [t = fs] []) adamc@1177: (f : $fs -> state -> state) (i : state) = adamc@1177: query q (fn r s => return (f r.t s)) i adamc@1177: adam@1394: fun queryL [tables] [exps] [tables ~ exps] (q : sql_query [] [] tables exps) = adamc@1081: query q adamc@1081: (fn r ls => return (r :: ls)) adamc@1081: [] adamc@1081: adam@1394: fun queryL1 [t ::: Name] [fs ::: {Type}] (q : sql_query [] [] [t = fs] []) = adam@1321: query q adam@1321: (fn r ls => return (r.t :: ls)) adam@1321: [] adam@1321: adamc@822: fun queryI [tables ::: {{Type}}] [exps ::: {Type}] adam@1394: [tables ~ exps] (q : sql_query [] [] tables exps) adamc@682: (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) adamc@682: -> transaction unit) = adamc@682: query q adamc@682: (fn fs _ => f fs) adamc@682: () adamc@682: adam@1394: fun queryI1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [] [nm = fs] []) adam@1363: (f : $fs -> transaction unit) = adam@1363: query q adam@1363: (fn fs _ => f fs.nm) adam@1363: () adam@1363: adamc@1004: fun queryX [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] adam@1394: [tables ~ exps] (q : sql_query [] [] tables exps) adamc@621: (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) adamc@1004: -> xml ctx inp []) = adamc@356: query q adamc@356: (fn fs acc => return {acc}{f fs}) adamc@360: adamc@341: adam@1405: fun rev [a] (ls : list a) : list a = adam@1405: let adam@1405: fun rev' ls acc = adam@1405: case ls of adam@1405: [] => acc adam@1405: | x :: ls => rev' ls (x :: acc) adam@1405: in adam@1405: rev' ls [] adam@1405: end adam@1405: adam@1405: fun queryXI [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] adam@1405: [tables ~ exps] (q : sql_query [] [] tables exps) adam@1405: (f : int -> $(exps ++ map (fn fields :: {Type} => $fields) tables) adam@1405: -> xml ctx inp []) = adam@1405: let adam@1405: fun qxi ls i = adam@1405: case ls of adam@1405: [] => adam@1405: | x :: ls => {f i x}{qxi ls (i+1)} adam@1405: in adam@1405: ls <- queryL q; adam@1406: return (qxi (rev ls) 0) adam@1405: end adam@1405: adamc@1076: fun queryX1 [nm ::: Name] [fs ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] adam@1394: (q : sql_query [] [] [nm = fs] []) adamc@1076: (f : $fs -> xml ctx inp []) = adamc@1076: query q adamc@1076: (fn fs acc => return {acc}{f fs.nm}) adamc@1076: adamc@1076: adam@1405: fun queryX1I [nm ::: Name] [fs ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] adam@1405: (q : sql_query [] [] [nm = fs] []) adam@1405: (f : int -> $fs -> xml ctx inp []) = adam@1405: let adam@1405: fun qx1i ls i = adam@1405: case ls of adam@1405: [] => adam@1405: | x :: ls => {f i x.nm}{qx1i ls (i+1)} adam@1405: in adam@1405: ls <- queryL q; adam@1406: return (qx1i (rev ls) 0) adam@1405: end adam@1405: adamc@1032: fun queryX' [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] adam@1394: [tables ~ exps] (q : sql_query [] [] tables exps) adamc@621: (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) adamc@1032: -> transaction (xml ctx inp [])) = adamc@469: query q adamc@469: (fn fs acc => adamc@469: r <- f fs; adamc@469: return {acc}{r}) adamc@469: adamc@469: adamc@1110: fun queryX1' [nm ::: Name] [fs ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] adam@1394: (q : sql_query [] [] [nm = fs] []) adamc@1110: (f : $fs -> transaction (xml ctx inp [])) = adamc@1110: query q adamc@1110: (fn fs acc => adamc@1110: r <- f fs.nm; adamc@1110: return {acc}{r}) adamc@1110: adamc@1110: adamc@1110: fun queryXE' [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] adam@1394: (q : sql_query [] [] [] exps) adamc@1110: (f : $exps -> transaction (xml ctx inp [])) = adamc@1110: query q adamc@1110: (fn fs acc => adamc@1110: r <- f fs; adamc@1110: return {acc}{r}) adamc@1110: adamc@1110: adamc@1072: fun hasRows [tables ::: {{Type}}] [exps ::: {Type}] adamc@1072: [tables ~ exps] adam@1394: (q : sql_query [] [] tables exps) = adamc@1072: query q adamc@1072: (fn _ _ => return True) adamc@1072: False adamc@1072: adamc@822: fun oneOrNoRows [tables ::: {{Type}}] [exps ::: {Type}] adamc@629: [tables ~ exps] adam@1394: (q : sql_query [] [] tables exps) = adamc@356: query q adamc@356: (fn fs _ => return (Some fs)) adamc@356: None adamc@440: adam@1394: fun oneOrNoRows1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [] [nm = fs] []) = adamc@1003: query q adamc@1003: (fn fs _ => return (Some fs.nm)) adamc@1003: None adamc@1003: adam@1394: fun oneOrNoRowsE1 [tabs ::: {Unit}] [nm ::: Name] [t ::: Type] [tabs ~ [nm]] (q : sql_query [] [] (mapU [] tabs) [nm = t]) = adamc@1006: query q adamc@1006: (fn fs _ => return (Some fs.nm)) adamc@1006: None adamc@1006: adamc@822: fun oneRow [tables ::: {{Type}}] [exps ::: {Type}] adam@1394: [tables ~ exps] (q : sql_query [] [] tables exps) = adamc@440: o <- oneOrNoRows q; adamc@440: return (case o of adamc@440: None => error Query returned no rows adamc@440: | Some r => r) adamc@440: adam@1394: fun oneRow1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [] [nm = fs] []) = adamc@1076: o <- oneOrNoRows q; adamc@1076: return (case o of adamc@1076: None => error Query returned no rows adamc@1076: | Some r => r.nm) adamc@1076: adam@1394: fun oneRowE1 [tabs ::: {Unit}] [nm ::: Name] [t ::: Type] [tabs ~ [nm]] (q : sql_query [] [] (mapU [] tabs) [nm = t]) = adamc@1003: o <- oneOrNoRows q; adamc@1003: return (case o of adamc@1003: None => error Query returned no rows adamc@1003: | Some r => r.nm) adamc@1003: adamc@1074: fun nonempty [fs] [us] (t : sql_table fs us) = adamc@1074: oneRowE1 (SELECT COUNT( * ) > 0 AS B FROM t) adamc@1074: adamc@822: fun eqNullable [tables ::: {{Type}}] [agg ::: {{Type}}] [exps ::: {Type}] adam@1778: [t ::: Type] (_ : sql_injectable (option t)) adam@1778: (e1 : sql_exp tables agg exps (option t)) adam@1778: (e2 : sql_exp tables agg exps (option t)) = adamc@471: (SQL ({e1} IS NULL AND {e2} IS NULL) OR {e1} = {e2}) adamc@470: adamc@822: fun eqNullable' [tables ::: {{Type}}] [agg ::: {{Type}}] [exps ::: {Type}] adam@1778: [t ::: Type] (_ : sql_injectable (option t)) adam@1778: (e1 : sql_exp tables agg exps (option t)) adamc@470: (e2 : option t) = adamc@470: case e2 of adamc@471: None => (SQL {e1} IS NULL) adamc@564: | Some _ => sql_binary sql_eq e1 (sql_inject e2) adam@1360: adam@1360: fun mkRead' [t ::: Type] (f : string -> option t) (name : string) : read t = adam@1360: mkRead (fn s => case f s of adam@1360: None => error Invalid {txt name}: {txt s} adam@1360: | Some v => v) f adam@1787: adam@1787: fun postFields pb = adam@1787: let adam@1787: fun postFields' s = adam@1787: case firstFormField s of adam@1787: None => [] adam@1787: | Some f => (fieldName f, fieldValue f) :: postFields' (remainingFields f) adam@1787: in adam@1787: case postType pb of adam@1787: "application/x-www-form-urlencoded" => postFields' (postData pb) adam@1787: | _ => error Tried to get POST fields, but MIME type is not "application/x-www-form-urlencoded" adam@1787: end