Update of /cvsroot/hcoop/domtool2/src
In directory sc8-pr-cvs17:/tmp/cvs-serv16571/src
Modified Files:
ast.sml main-client.sml main.sig main.sml sources tycheck.sml
Added Files:
describe.sig describe.sml
Log Message:
Factor error message generation into a separate file; add '-tc' flag to
domtool-client
Index: tycheck.sml
===================================================================
RCS file: /cvsroot/hcoop/domtool2/src/tycheck.sml,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** tycheck.sml 10 Dec 2006 20:09:28 -0000 1.14
--- tycheck.sml 26 May 2007 16:11:33 -0000 1.15
***************
*** 1,4 ****
(* HCoop Domtool (http://hcoop.sourceforge.net/)
! * Copyright (c) 2006, Adam Chlipala
*
* This program is free software; you can redistribute it and/or
--- 1,4 ----
(* HCoop Domtool (http://hcoop.sourceforge.net/)
! * Copyright (c) 2006-2007, Adam Chlipala
*
* This program is free software; you can redistribute it and/or
***************
*** 104,162 ****
| _ => false
- datatype unification_error =
- UnifyPred of pred * pred
- | UnifyTyp of typ * typ
- | UnifyOccurs of string * typ
-
- exception Unify of unification_error
-
- datatype type_error =
- WrongType of string * exp * typ * typ * unification_error option
- | WrongForm of string * string * exp * typ * unification_error option
- | UnboundVariable of string
- | WrongPred of string * pred * pred
-
- fun describe_unification_error t ue =
- case ue of
- UnifyPred (p1, p2) =>
- (print "Reason: Incompatible contexts.\n";
- preface ("Have:", p_pred p1);
- preface ("Need:", p_pred p2))
- | UnifyTyp (t1, t2) =>
- if eqTy (t, t1) then
- ()
- else
- (print "Reason: Incompatible types.\n";
- preface ("Have:", p_typ t1);
- preface ("Need:", p_typ t2))
- | UnifyOccurs (name, t') =>
- if eqTy (t, t') then
- ()
- else
- (print "Reason: Occurs check failed for ";
- print name;
- print " in:\n";
- printd (p_typ t))
-
- fun describe_type_error loc te =
- case te of
- WrongType (place, e, t1, t2, ueo) =>
- (ErrorMsg.error (SOME loc) (place ^ " has wrong type.");
- preface (" Expression:", p_exp e);
- preface ("Actual type:", p_typ t1);
- preface ("Needed type:", p_typ t2);
- Option.app (describe_unification_error t1) ueo)
- | WrongForm (place, form, e, t, ueo) =>
- (ErrorMsg.error (SOME loc) (place ^ " has a non-" ^ form ^ " type.");
- preface ("Expression:", p_exp e);
- preface (" Type:", p_typ t);
- Option.app (describe_unification_error t) ueo)
- | UnboundVariable name =>
- ErrorMsg.error (SOME loc) ("Unbound variable " ^ name ^ ".\n")
- | WrongPred (place, p1, p2) =>
- (ErrorMsg.error (SOME loc) ("Context incompatibility for " ^ place ^
".");
- preface ("Have:", p_pred p1);
- preface ("Need:", p_pred p2))
-
fun predImplies (p1All as (p1, _), p2All as (p2, _)) =
case (p1, p2) of
--- 104,107 ----
***************
*** 360,364 ****
fun checkExp G (eAll as (e, loc)) =
let
! val dte = describe_type_error loc
in
case e of
--- 305,309 ----
fun checkExp G (eAll as (e, loc)) =
let
! val dte = Describe.describe_type_error loc
in
case e of
***************
*** 731,740 ****
hasTyp (e, t, to)
handle Unify ue =>
! describe_type_error loc
! (WrongType ("Bound value",
! e,
! t,
! to,
! SOME ue));
bindVal G (name, to, SOME e)
end
--- 676,685 ----
hasTyp (e, t, to)
handle Unify ue =>
! Describe.describe_type_error loc
! (WrongType ("Bound value",
! e,
! t,
! to,
! SOME ue));
bindVal G (name, to, SOME e)
end
Index: main.sig
===================================================================
RCS file: /cvsroot/hcoop/domtool2/src/main.sig,v
retrieving revision 1.37
retrieving revision 1.38
diff -C2 -d -r1.37 -r1.38
*** main.sig 25 Feb 2007 19:10:37 -0000 1.37
--- main.sig 26 May 2007 16:11:32 -0000 1.38
***************
*** 22,25 ****
--- 22,26 ----
val init : unit -> unit
+ val setupUser : unit -> string
val check : string -> Env.env * Ast.exp option
--- NEW FILE: describe.sml ---
(* HCoop Domtool (http://hcoop.sourceforge.net/)
* Copyright (c) 2006-2007, Adam Chlipala
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
USA.
*)
(* Error message generation *)
structure Describe :> DESCRIBE = struct
open Ast Print
structure SM = StringMap
exception UnequalDomains
fun eqRecord f (r1, r2) =
(SM.appi (fn (k, v1) =>
case SM.find (r2, k) of
NONE => raise UnequalDomains
| SOME v2 =>
if f (v1, v2) then
()
else
raise UnequalDomains) r1;
SM.appi (fn (k, v2) =>
case SM.find (r1, k) of
NONE => raise UnequalDomains
| SOME v1 =>
if f (v1, v2) then
()
else
raise UnequalDomains) r2;
true)
handle UnequalDomains => false
fun eqPred ((p1, _), (p2, _)) =
case (p1, p2) of
(CRoot, CRoot) => true
| (CConst s1, CConst s2) => s1 = s2
| (CPrefix p1, CPrefix p2) => eqPred (p1, p2)
| (CNot p1, CNot p2) => eqPred (p1, p2)
| (CAnd (p1, q1), CAnd (p2, q2)) =>
eqPred (p1, p2) andalso eqPred (q1, q2)
| _ => false
fun eqTy (t1All as (t1, _), t2All as (t2, _)) =
case (t1, t2) of
(TBase s1, TBase s2) => s1 = s2
| (TList t1, TList t2) => eqTy (t1, t2)
| (TArrow (d1, r1), TArrow (d2, r2)) =>
eqTy (d1, d2) andalso eqTy (r1, r2)
| (TAction (p1, d1, r1), TAction (p2, d2, r2)) =>
eqPred (p1, p2) andalso eqRecord eqTy (d1, d2)
andalso eqRecord eqTy (r1, r2)
| (TNested (p1, q1), TNested (p2, q2)) =>
eqPred (p1, p2) andalso eqTy (q1, q2)
| (TUnif (_, ref (SOME t1)), _) => eqTy (t1, t2All)
| (_, TUnif (_, ref (SOME t2))) => eqTy (t1All, t2)
| (TUnif (_, r1), TUnif (_, r2)) => r1 = r2
| (TError, TError) => true
| _ => false
fun describe_unification_error t ue =
case ue of
UnifyPred (p1, p2) =>
(print "Reason: Incompatible contexts.\n";
preface ("Have:", p_pred p1);
preface ("Need:", p_pred p2))
| UnifyTyp (t1, t2) =>
if eqTy (t, t1) then
()
else
(print "Reason: Incompatible types.\n";
preface ("Have:", p_typ t1);
preface ("Need:", p_typ t2))
| UnifyOccurs (name, t') =>
if eqTy (t, t') then
()
else
(print "Reason: Occurs check failed for ";
print name;
print " in:\n";
printd (p_typ t))
fun describe_type_error loc te =
case te of
WrongType (place, e, t1, t2, ueo) =>
(ErrorMsg.error (SOME loc) (place ^ " has wrong type.");
preface (" Expression:", p_exp e);
preface ("Actual type:", p_typ t1);
preface ("Needed type:", p_typ t2);
Option.app (describe_unification_error t1) ueo)
| WrongForm (place, form, e, t, ueo) =>
(ErrorMsg.error (SOME loc) (place ^ " has a non-" ^ form ^ " type.");
preface ("Expression:", p_exp e);
preface (" Type:", p_typ t);
Option.app (describe_unification_error t) ueo)
| UnboundVariable name =>
ErrorMsg.error (SOME loc) ("Unbound variable " ^ name ^ ".\n")
| WrongPred (place, p1, p2) =>
(ErrorMsg.error (SOME loc) ("Context incompatibility for " ^ place ^
".");
preface ("Have:", p_pred p1);
preface ("Need:", p_pred p2))
end
Index: sources
===================================================================
RCS file: /cvsroot/hcoop/domtool2/src/sources,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** sources 10 Apr 2007 03:03:05 -0000 1.14
--- sources 26 May 2007 16:11:33 -0000 1.15
***************
*** 25,28 ****
--- 25,31 ----
env.sml
+ describe.sig
+ describe.sml
+
tycheck.sig
tycheck.sml
Index: main-client.sml
===================================================================
RCS file: /cvsroot/hcoop/domtool2/src/main-client.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** main-client.sml 4 Apr 2007 16:44:58 -0000 1.5
--- main-client.sml 26 May 2007 16:11:32 -0000 1.6
***************
*** 28,39 ****
end
! val _ =
case CommandLine.arguments () of
[fname] =>
if Posix.FileSys.access (fname, []) then
! Main.request fname
else
! Main.request (OS.Path.joinDirFile {dir = domtoolRoot (),
! file = fname})
| [] => Main.requestDir (domtoolRoot ())
| _ => print "Invalid command-line arguments\n"
--- 28,44 ----
end
! val (doit, args) =
case CommandLine.arguments () of
+ "-tc" :: args => (fn fname => (Main.setupUser (); ignore (Main.check
fname)), args)
+ | args => (Main.request, args)
+
+ val _ =
+ case args of
[fname] =>
if Posix.FileSys.access (fname, []) then
! doit fname
else
! doit (OS.Path.joinDirFile {dir = domtoolRoot (),
! file = fname})
| [] => Main.requestDir (domtoolRoot ())
| _ => print "Invalid command-line arguments\n"
Index: ast.sml
===================================================================
RCS file: /cvsroot/hcoop/domtool2/src/ast.sml,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** ast.sml 9 Dec 2006 02:41:53 -0000 1.12
--- ast.sml 26 May 2007 16:11:32 -0000 1.13
***************
*** 106,108 ****
--- 106,121 ----
foldl (fn (arg, e) => (EApp (e, arg), loc)) f args
+ datatype unification_error =
+ UnifyPred of pred * pred
+ | UnifyTyp of typ * typ
+ | UnifyOccurs of string * typ
+
+ exception Unify of unification_error
+
+ datatype type_error =
+ WrongType of string * exp * typ * typ * unification_error option
+ | WrongForm of string * string * exp * typ * unification_error option
+ | UnboundVariable of string
+ | WrongPred of string * pred * pred
+
end
--- NEW FILE: describe.sig ---
(* HCoop Domtool (http://hcoop.sourceforge.net/)
* Copyright (c) 2006-2007, Adam Chlipala
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
USA.
*)
(* Error message generation *)
signature DESCRIBE = sig
val describe_unification_error : Ast.typ -> Ast.unification_error -> unit
val describe_type_error : Ast.position -> Ast.type_error -> unit
end
Index: main.sml
===================================================================
RCS file: /cvsroot/hcoop/domtool2/src/main.sml,v
retrieving revision 1.70
retrieving revision 1.71
diff -C2 -d -r1.70 -r1.71
*** main.sml 17 May 2007 19:12:40 -0000 1.70
--- main.sml 26 May 2007 16:11:32 -0000 1.71
***************
*** 177,181 ****
raise e)
! fun requestContext f =
let
val user =
--- 177,181 ----
raise e)
! fun setupUser () =
let
val user =
***************
*** 188,194 ****
end
| SOME user => user
!
! val () = Acl.read Config.aclFile
! val () = Domain.setUser user
val () = f ()
--- 188,200 ----
end
| SOME user => user
! in
! Acl.read Config.aclFile;
! Domain.setUser user;
! user
! end
!
! fun requestContext f =
! let
! val user = setupUser ()
val () = f ()
-------------------------------------------------------------------------
This SF.net email is sponsored by DB2 Express
Download DB2 Express C - the FREE version of DB2 express and take
control of your XML. No limits. Just data. Click to get it now.
http://sourceforge.net/powerbar/db2/
_______________________________________________
hcoop-cvs mailing list
hcoop-cvs@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/hcoop-cvs
