[MLton-commit] r4819
Stephen Weeks
sweeks at mlton.org
Mon Nov 13 13:08:49 PST 2006
Improved error reporting. In particular use the file name as it
occurred in the user's input (e.g. in an MLB) rather than after we
regularize it. This fixes a bug on Cygwin where a user could have
/a/b/c/d.sml
in an MLB file and, if that file didn't exist would get an error
message involving
/a\b\c\d.sml
----------------------------------------------------------------------
U mlton/trunk/mlton/cm/cm.sml
U mlton/trunk/mlton/control/control.sig
U mlton/trunk/mlton/control/control.sml
U mlton/trunk/mlton/front-end/mlb-front-end.fun
U mlton/trunk/mlton/main/main.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/cm/cm.sml
===================================================================
--- mlton/trunk/mlton/cm/cm.sml 2006-11-13 17:26:06 UTC (rev 4818)
+++ mlton/trunk/mlton/cm/cm.sml 2006-11-13 21:08:43 UTC (rev 4819)
@@ -73,17 +73,20 @@
List.push (files, finalize m')
in
Control.checkFile
- (m, fail, fn () =>
- case File.suffix m of
- SOME "cm" =>
- loop (m, 0, relativize)
- | SOME "sml" => sml ()
- | SOME "sig" => sml ()
- | SOME "fun" => sml ()
- | SOME "ML" => sml ()
- | _ =>
- fail (concat ["MLton can't process ",
- m]))
+ (m,
+ {fail = fail,
+ name = m,
+ ok = fn () =>
+ case File.suffix m of
+ SOME "cm" =>
+ loop (m, 0, relativize)
+ | SOME "sml" => sml ()
+ | SOME "sig" => sml ()
+ | SOME "fun" => sml ()
+ | SOME "ML" => sml ()
+ | _ =>
+ fail (concat ["MLton can't process ",
+ m])})
end
end)
end)
Modified: mlton/trunk/mlton/control/control.sig
===================================================================
--- mlton/trunk/mlton/control/control.sig 2006-11-13 17:26:06 UTC (rev 4818)
+++ mlton/trunk/mlton/control/control.sig 2006-11-13 21:08:43 UTC (rev 4819)
@@ -32,7 +32,9 @@
(*------------------------------------*)
(* Error Reporting *)
(*------------------------------------*)
- val checkFile: File.t * (string -> 'a) * (unit -> 'a) -> 'a
+ val checkFile: File.t * {fail: string -> 'a,
+ name: string,
+ ok: unit -> 'a} -> 'a
val checkForErrors: string -> unit
val error: Region.t * Layout.t * Layout.t -> unit
val errorStr: Region.t * string -> unit
Modified: mlton/trunk/mlton/control/control.sml
===================================================================
--- mlton/trunk/mlton/control/control.sml 2006-11-13 17:26:06 UTC (rev 4818)
+++ mlton/trunk/mlton/control/control.sml 2006-11-13 21:08:43 UTC (rev 4819)
@@ -235,15 +235,15 @@
then die (concat ["compilation aborted: ", name, " reported errors"])
else ()
-fun checkFile (f: File.t, error: string -> 'a, k: unit -> 'a): 'a =
- let
- fun check (test, msg, k) =
- if not (test f)
- then error (concat ["File ", f, " ", msg])
- else k ()
+fun checkFile (f: File.t, {fail: string -> 'a, name, ok: unit -> 'a}): 'a = let
+ fun check (test, msg, k) =
+ if test f then
+ k ()
+ else
+ fail (concat ["File ", name, " ", msg])
in
check (File.doesExist, "does not exist", fn () =>
- check (File.canRead, "cannot be read", k))
+ check (File.canRead, "cannot be read", ok))
end
(*---------------------------------------------------*)
Modified: mlton/trunk/mlton/front-end/mlb-front-end.fun
===================================================================
--- mlton/trunk/mlton/front-end/mlb-front-end.fun 2006-11-13 17:26:06 UTC (rev 4818)
+++ mlton/trunk/mlton/front-end/mlb-front-end.fun 2006-11-13 21:08:43 UTC (rev 4819)
@@ -201,63 +201,67 @@
("fileUse", File.layout fileUse),
("relativize", Option.layout Dir.layout relativize)])
regularize
- fun lexAndParseProg {fileAbs: File.t, fileUse: File.t,
+ fun lexAndParseProg {fileAbs: File.t, fileOrig: File.t, fileUse: File.t,
fail: String.t -> Ast.Program.t} =
Ast.Basdec.Prog
({fileAbs = fileAbs, fileUse = fileUse},
Promise.delay
(fn () =>
Control.checkFile
- (fileUse, fail, fn () => FrontEnd.lexAndParseFile fileUse)))
+ (fileUse, {fail = fail,
+ name = fileOrig,
+ ok = fn () => FrontEnd.lexAndParseFile fileUse})))
and lexAndParseMLB {relativize: Dir.t option,
seen: (File.t * File.t * Region.t) list,
- fileAbs: File.t, fileUse: File.t,
+ fileAbs: File.t, fileOrig: File.t, fileUse: File.t,
fail: String.t -> Ast.Basdec.t, reg: Region.t} =
Ast.Basdec.MLB
({fileAbs = fileAbs, fileUse = fileUse},
Promise.delay
(fn () =>
Control.checkFile
- (fileUse, fail, fn () =>
- let
- val seen' = (fileAbs, fileUse, reg) :: seen
- in
- if List.exists (seen, fn (fileAbs', _, _) =>
- String.equals (fileAbs, fileAbs'))
- then (let open Layout
- in
- Control.error
- (reg, seq [str "Basis forms a cycle with ",
- File.layout fileUse],
- align (List.map (seen', fn (_, f, r) =>
- seq [Region.layout r,
- str ": ",
- File.layout f])))
- ; Ast.Basdec.empty
- end)
- else
- let
- val (_, basdec) =
- HashSet.lookupOrInsert
- (psi, String.hash fileAbs, fn (fileAbs', _) =>
- String.equals (fileAbs, fileAbs'), fn () =>
- let
- val cwd = OS.Path.dir fileAbs
- val basdec =
- Promise.delay
- (fn () =>
- wrapLexAndParse
- ({cwd = cwd,
- relativize = relativize,
- seen = seen'},
- lexAndParseFile, fileUse))
- in
- (fileAbs, basdec)
- end)
- in
- Promise.force basdec
- end
- end)))
+ (fileUse,
+ {fail = fail,
+ name = fileOrig,
+ ok = fn () => let
+ val seen' = (fileAbs, fileUse, reg) :: seen
+ in
+ if List.exists (seen, fn (fileAbs', _, _) =>
+ String.equals (fileAbs, fileAbs'))
+ then (let open Layout
+ in
+ Control.error
+ (reg, seq [str "Basis forms a cycle with ",
+ File.layout fileUse],
+ align (List.map (seen', fn (_, f, r) =>
+ seq [Region.layout r,
+ str ": ",
+ File.layout f])))
+ ; Ast.Basdec.empty
+ end)
+ else
+ let
+ val (_, basdec) =
+ HashSet.lookupOrInsert
+ (psi, String.hash fileAbs, fn (fileAbs', _) =>
+ String.equals (fileAbs, fileAbs'), fn () =>
+ let
+ val cwd = OS.Path.dir fileAbs
+ val basdec =
+ Promise.delay
+ (fn () =>
+ wrapLexAndParse
+ ({cwd = cwd,
+ relativize = relativize,
+ seen = seen'},
+ lexAndParseFile, fileUse))
+ in
+ (fileAbs, basdec)
+ end)
+ in
+ Promise.force basdec
+ end
+ end})))
and lexAndParseProgOrMLB {cwd, relativize, seen}
(fileOrig: File.t, reg: Region.t) =
let
@@ -274,23 +278,28 @@
end
val mlbExts = ["mlb"]
val progExts = ["ML","fun","sig","sml"]
- fun err () = fail (Ast.Basdec.Seq []) "has an unknown extension"
+ fun err () =
+ fail (Ast.Basdec.Seq [])
+ (concat ["File ", fileOrig, " has an unknown extension"])
in
case File.extension fileUse of
NONE => err ()
| SOME s =>
- if List.contains (mlbExts, s, String.equals)
- then lexAndParseMLB {relativize = relativize,
- seen = seen,
- fileAbs = fileAbs,
- fileUse = fileUse,
- fail = fail Ast.Basdec.empty,
- reg = reg}
- else if List.contains (progExts, s, String.equals)
- then lexAndParseProg {fileAbs = fileAbs,
- fileUse = fileUse,
- fail = fail Ast.Program.empty}
- else err ()
+ if List.contains (mlbExts, s, String.equals) then
+ lexAndParseMLB {relativize = relativize,
+ seen = seen,
+ fileAbs = fileAbs,
+ fileOrig = fileOrig,
+ fileUse = fileUse,
+ fail = fail Ast.Basdec.empty,
+ reg = reg}
+ else if List.contains (progExts, s, String.equals) then
+ lexAndParseProg {fileAbs = fileAbs,
+ fileOrig = fileOrig,
+ fileUse = fileUse,
+ fail = fail Ast.Program.empty}
+ else
+ err ()
end
and wrapLexAndParse (state, lexAndParse, arg) =
Ref.fluidLet
Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun 2006-11-13 17:26:06 UTC (rev 4818)
+++ mlton/trunk/mlton/main/main.fun 2006-11-13 21:08:43 UTC (rev 4819)
@@ -1041,8 +1041,10 @@
Place.CM => compileCM input
| Place.SML =>
Control.checkFile
- (input, fn s => raise Fail s,
- fn () => compileSml [input])
+ (input,
+ {fail = fn s => raise Fail s,
+ name = input,
+ ok = fn () => compileSml [input]})
| Place.MLB => compileMLB input
| Place.Generated => compileCSO (input :: csoFiles)
| Place.O => compileCSO (input :: csoFiles)
More information about the MLton-commit
mailing list