Mercurial > urweb

annotate src/pathcheck.sml @ 1642:c3627f317bfd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Refactor HTML contexts to prevent some illegal nestings (that can crash the JavaScript runtime system)
author Adam Chlipala <adam@chlipala.net>
date Tue, 20 Dec 2011 21:06:25 -0500
parents 72670131dace
children c1e3805e604e
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@725 39 fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) =
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@725 46 (SS.add (funcs, s), rels, cookies, styles))
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@725 53 (funcs, SS.add (rels, s), cookies, styles))
adamc@725 54
adamc@725 55 fun doCookie s =
adamc@725 56 (if SS.member (cookies, s) then
adamc@725 57 E.errorAt loc ("Duplicate cookie path " ^ s)
adamc@725 58 else
adamc@725 59 ();
adamc@725 60 (funcs, rels, SS.add (cookies, s), styles))
adamc@725 61
adamc@725 62 fun doStyle s =
adamc@725 63 (if SS.member (styles, s) then
adamc@725 64 E.errorAt loc ("Duplicate style path " ^ s)
adamc@725 65 else
adamc@725 66 ();
adamc@725 67 (funcs, rels, cookies, SS.add (styles, s)))
adamc@377 68 in
adamc@377 69 case d of
adamc@1104 70 DExport (_, s, _, _, _, _) => doFunc s
adamc@377 71
adamc@707 72 | DTable (s, _, pe, ce) =>
adamc@704 73 let
adamc@704 74 fun constraints (e, rels) =
adamc@704 75 case #1 e of
adamc@704 76 ERecord [(s', _, _)] =>
adamc@704 77 let
adamc@704 78 val s' = s ^ "_" ^ s'
adamc@704 79 in
adamc@704 80 if SS.member (rels, s') then
adamc@704 81 E.errorAt loc ("Duplicate constraint path " ^ s')
adamc@704 82 else
adamc@704 83 ();
adamc@704 84 SS.add (rels, s')
adamc@704 85 end
adamc@704 86 | EStrcat (e1, e2) => constraints (e2, constraints (e1, rels))
adamc@704 87 | _ => rels
adamc@707 88
adamc@707 89 val rels = #2 (doRel s)
adamc@707 90 val rels = case #1 pe of
adamc@707 91 EPrim (Prim.String "") => rels
adamc@707 92 | _ =>
adamc@707 93 let
adamc@707 94 val s' = s ^ "_Pkey"
adamc@707 95 in
adamc@707 96 if SS.member (rels, s') then
adamc@707 97 E.errorAt loc ("Duplicate primary key constraint path " ^ s')
adamc@707 98 else
adamc@707 99 ();
adamc@707 100 SS.add (rels, s')
adamc@707 101 end
adamc@704 102 in
adamc@725 103 (funcs, constraints (ce, rels), cookies, styles)
adamc@704 104 end
adamc@377 105 | DSequence s => doRel s
adamc@377 106
adamc@725 107 | DCookie s => doCookie s
adamc@725 108 | DStyle s => doStyle s
adamc@725 109
adamc@725 110 | _ => (funcs, rels, cookies, styles)
adamc@377 111 end
adamc@377 112
adamc@725 113 fun check ds = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) ds)
adamc@377 114
adamc@377 115 end