Mercurial > urweb

comparison src/lacweb.grm @ 233:c466678af854

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
SELECTing arbitrary expressions
author Adam Chlipala <adamc@hcoop.net>
date Thu, 28 Aug 2008 11:17:14 -0400
parents a338da9d82f3
children 82409ef72019
comparison
equal deleted inserted replaced
232:a338da9d82f3 233:c466678af854
40 TRecord c => c 40 TRecord c => c
41 | _ => t 41 | _ => t
42 42
43 datatype select_item = 43 datatype select_item =
44 Field of con * con 44 Field of con * con
45 | Exp of con * exp
45 46
46 datatype select = 47 datatype select =
47 Star 48 Star
48 | Items of select_item list 49 | Items of select_item list
49 50
54 case (c1, c2) of 55 case (c1, c2) of
55 (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2 56 (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2
56 | (CName x1, CName x2) => x1 = x2 57 | (CName x1, CName x2) => x1 = x2
57 | _ => false 58 | _ => false
58 59
59 fun amend_select loc (si, tabs) = 60 fun amend_select loc (si, (tabs, exps)) =
60 let 61 case si of
61 val (tx, c) = case si of 62 Field (tx, fx) =>
62 Field (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)) 63 let
63 64 val c = (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)
64 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => 65
65 if eqTnames (tx, tx') then 66 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
66 ((tx', (CConcat (c, c'), loc)), true) 67 if eqTnames (tx, tx') then
67 else 68 ((tx', (CConcat (c, c'), loc)), true)
68 ((tx', c'), found)) 69 else
69 false tabs 70 ((tx', c'), found))
70 in 71 false tabs
71 if found then 72 in
72 () 73 if found then
73 else 74 ()
74 ErrorMsg.errorAt loc "Select of field from unbound table"; 75 else
75 76 ErrorMsg.errorAt loc "Select of field from unbound table";
76 tabs 77
77 end 78 (tabs, exps)
79 end
80 | Exp (c, e) => (tabs, (c, e) :: exps)
78 81
79 fun amend_group loc (gi, tabs) = 82 fun amend_group loc (gi, tabs) =
80 let 83 let
81 val (tx, c) = case gi of 84 val (tx, c) = case gi of
82 GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)) 85 GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc))
679 682
680 query1 : SELECT select FROM tables wopt gopt hopt 683 query1 : SELECT select FROM tables wopt gopt hopt
681 (let 684 (let
682 val loc = s (SELECTleft, tablesright) 685 val loc = s (SELECTleft, tablesright)
683 686
684 val sel = 687 val (sel, exps) =
685 case select of 688 case select of
686 Star => map (fn (nm, _) => 689 Star => (map (fn (nm, _) =>
687 (nm, (CTuple [(CWild (KRecord (KType, loc), loc), 690 (nm, (CTuple [(CWild (KRecord (KType, loc), loc),
688 loc), 691 loc),
689 (CRecord [], loc)], 692 (CRecord [], loc)],
690 loc))) tables 693 loc))) tables,
694 [])
691 | Items sis => 695 | Items sis =>
692 let 696 let
693 val tabs = map (fn (nm, _) => (nm, (CRecord [], loc))) tables 697 val tabs = map (fn (nm, _) => (nm, (CRecord [], loc))) tables
694 val tabs = foldl (amend_select loc) tabs sis 698 val (tabs, exps) = foldl (amend_select loc) (tabs, []) sis
695 in 699 in
696 map (fn (nm, c) => (nm, 700 (map (fn (nm, c) => (nm,
697 (CTuple [c, 701 (CTuple [c,
698 (CWild (KRecord (KType, loc), loc), 702 (CWild (KRecord (KType, loc), loc),
699 loc)], loc))) tabs 703 loc)], loc))) tabs,
704 exps)
700 end 705 end
701 706
702 val sel = (CRecord sel, loc) 707 val sel = (CRecord sel, loc)
703 708
704 val grp = case gopt of 709 val grp = case gopt of
731 grp), 736 grp),
732 ((CName "Having", loc), 737 ((CName "Having", loc),
733 hopt), 738 hopt),
734 ((CName "SelectFields", loc), 739 ((CName "SelectFields", loc),
735 (ECApp ((EVar (["Basis"], "sql_subset"), loc), 740 (ECApp ((EVar (["Basis"], "sql_subset"), loc),
736 sel), loc))], loc) 741 sel), loc)),
742 ((CName "SelectExps", loc),
743 (ERecord exps, loc))], loc)
737 744
738 val e = (EApp (e, re), loc) 745 val e = (EApp (e, re), loc)
739 in 746 in
740 e 747 e
741 end) 748 end)
760 767
761 fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) 768 fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
762 | LBRACE cexp RBRACE (cexp) 769 | LBRACE cexp RBRACE (cexp)
763 770
764 seli : tident DOT fident (Field (tident, fident)) 771 seli : tident DOT fident (Field (tident, fident))
772 | sqlexp AS fident (Exp (fident, sqlexp))
765 773
766 selis : seli ([seli]) 774 selis : seli ([seli])
767 | seli COMMA selis (seli :: selis) 775 | seli COMMA selis (seli :: selis)
768 776
769 select : STAR (Star) 777 select : STAR (Star)