Mercurial > urweb

annotate src/pathcheck.sml @ 709:0406e9cccb72

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
FOREIGN KEY, without ability to link NULL to NOT NULL (and with some lingering problems in row inference)
author Adam Chlipala <adamc@hcoop.net>
date Tue, 07 Apr 2009 18:47:47 -0400
parents d8217b4cb617
children 4c5796512edc
rev   line source
adamc@377 1 (* Copyright (c) 2008, Adam Chlipala
adamc@377 2 * All rights reserved.
adamc@377 3 *
adamc@377 4 * Redistribution and use in source and binary forms, with or without
adamc@377 5 * modification, are permitted provided that the following conditions are met:
adamc@377 6 *
adamc@377 7 * - Redistributions of source code must retain the above copyright notice,
adamc@377 8 * this list of conditions and the following disclaimer.
adamc@377 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@377 10 * this list of conditions and the following disclaimer in the documentation
adamc@377 11 * and/or other materials provided with the distribution.
adamc@377 12 * - The names of contributors may not be used to endorse or promote products
adamc@377 13 * derived from this software without specific prior written permission.
adamc@377 14 *
adamc@377 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@377 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@377 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@377 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@377 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@377 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@377 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@377 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@377 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@377 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@377 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@377 26 *)
adamc@377 27
adamc@377 28 structure PathCheck :> PATH_CHECK = struct
adamc@377 29
adamc@377 30 open Mono
adamc@377 31
adamc@377 32 structure E = ErrorMsg
adamc@377 33
adamc@377 34 structure SS = BinarySetFn(struct
adamc@377 35 type ord_key = string
adamc@377 36 val compare = String.compare
adamc@377 37 end)
adamc@377 38
adamc@377 39 fun checkDecl ((d, loc), (funcs, rels)) =
adamc@377 40 let
adamc@704 41 fun doFunc s =
adamc@704 42 (if SS.member (funcs, s) then
adamc@704 43 E.errorAt loc ("Duplicate function path " ^ s)
adamc@704 44 else
adamc@704 45 ();
adamc@704 46 (SS.add (funcs, s), rels))
adamc@704 47
adamc@377 48 fun doRel s =
adamc@377 49 (if SS.member (rels, s) then
adamc@377 50 E.errorAt loc ("Duplicate table/sequence path " ^ s)
adamc@377 51 else
adamc@377 52 ();
adamc@377 53 (funcs, SS.add (rels, s)))
adamc@377 54 in
adamc@377 55 case d of
adamc@704 56 DExport (_, s, _, _, _) => doFunc s
adamc@377 57
adamc@707 58 | DTable (s, _, pe, ce) =>
adamc@704 59 let
adamc@704 60 fun constraints (e, rels) =
adamc@704 61 case #1 e of
adamc@704 62 ERecord [(s', _, _)] =>
adamc@704 63 let
adamc@704 64 val s' = s ^ "_" ^ s'
adamc@704 65 in
adamc@704 66 if SS.member (rels, s') then
adamc@704 67 E.errorAt loc ("Duplicate constraint path " ^ s')
adamc@704 68 else
adamc@704 69 ();
adamc@704 70 SS.add (rels, s')
adamc@704 71 end
adamc@704 72 | EStrcat (e1, e2) => constraints (e2, constraints (e1, rels))
adamc@704 73 | _ => rels
adamc@707 74
adamc@707 75 val rels = #2 (doRel s)
adamc@707 76 val rels = case #1 pe of
adamc@707 77 EPrim (Prim.String "") => rels
adamc@707 78 | _ =>
adamc@707 79 let
adamc@707 80 val s' = s ^ "_Pkey"
adamc@707 81 in
adamc@707 82 if SS.member (rels, s') then
adamc@707 83 E.errorAt loc ("Duplicate primary key constraint path " ^ s')
adamc@707 84 else
adamc@707 85 ();
adamc@707 86 SS.add (rels, s')
adamc@707 87 end
adamc@704 88 in
adamc@707 89 (funcs, constraints (ce, rels))
adamc@704 90 end
adamc@377 91 | DSequence s => doRel s
adamc@377 92
adamc@377 93 | _ => (funcs, rels)
adamc@377 94 end
adamc@377 95
adamc@377 96 fun check ds = ignore (foldl checkDecl (SS.empty, SS.empty) ds)
adamc@377 97
adamc@377 98 end