open Test_harness let position line col offset = { Location.line = line; col = col; offset = offset } let span line1 col1 line2 col2 = Location.make (position line1 col1 0) (position line2 col2 10) let location_cases = let open Location in [ ( "merge of two spans uses first start and second stop", fun () -> check_equal_string "merged span" "1:2-3:4" (to_string (merge (span 1 2 1 5) (span 3 1 3 4))) ); ("merge with none returns the other span", fun () -> check_equal_string "none merge" "2:3-2:3" (to_string (merge none (point (position 2 3 7))))); ("is_none distinguishes the empty span", fun () -> check "none is none" (is_none none); check "point is not none" (not (is_none (point (position 1 1 0))))); ("size measures offsets", fun () -> check_equal_int "size" 10 (size (span 1 1 2 1))); ("pos_to_string renders line and column", fun () -> check_equal_string "pos" "12:34" (pos_to_string (position 12 34 100))); ] let ident_cases = [ ( "fresh identifiers get distinct stamps", fun () -> Ident.reset (); let a = Ident.fresh "x" Location.none in let b = Ident.fresh "x" Location.none in check "distinct" (not (Ident.equal a b)); check_equal_int "compare is stamp order" (-1) (Ident.compare a b) ); ( "display keeps the source name while to_string is unique", fun () -> Ident.reset (); let a = Ident.fresh "row" Location.none in check_equal_string "display" "row" (Ident.display a); check_equal_string "to_string" "row#1" (Ident.to_string a) ); ( "reset restarts numbering deterministically", fun () -> Ident.reset (); let first = Ident.fresh "x" Location.none in Ident.reset (); let second = Ident.fresh "x" Location.none in check_equal_int "same stamp after reset" (Ident.stamp first) (Ident.stamp second) ); ( "identifiers carry their source span", fun () -> Ident.reset (); let a = Ident.fresh "x" (span 4 5 4 6) in check_equal_string "span" "4:5-4:6" (Location.to_string (Ident.span a)) ); ] let diagnostic_cases = [ ( "diagnostic renders file line column and message", fun () -> let d = Diagnostic.make (span 2 3 2 4) "unknown variable total" in check_equal_string "to_string" ":2:3: error: unknown variable total" (Diagnostic.to_string d) ); ( "diagnostic renders a source excerpt with carets", fun () -> let d = Diagnostic.make (span 2 5 2 9) "bad field" in let rendered = Diagnostic.render (Some "let a = 1\nlet b = a.bad\n") d in check_true "rendered contains header" rendered (rendered = ":2:5: error: bad field\n let b = a.bad\n ^^^^") ); ( "error raises with the current file", fun () -> Diagnostic.set_file "sample.delta"; (try Diagnostic.error (span 1 1 1 2) "boom"; fail "raises" "expected an error" with Diagnostic.Error d -> check_equal_string "file" "sample.delta" d.Diagnostic.file); Diagnostic.set_file "" ); ] let parse text = Parse.expression text let parse_error text = try ignore (parse text); None with Diagnostic.Error diagnostic -> Some diagnostic let parse_cases = [ ( "integer and operator spans are recorded", fun () -> let parsed = parse "1 + 20" in check_equal_string "whole span" "1:1-1:7" (Location.to_string parsed.Syntax.espan); match parsed.Syntax.e with | Syntax.EBinop (Syntax.Add, left, right) -> check_equal_string "left span" "1:1-1:2" (Location.to_string left.Syntax.espan); check_equal_string "right span" "1:5-1:7" (Location.to_string right.Syntax.espan) | _ -> fail "shape" "expected an addition" ); ( "pipeline is right associative application", fun () -> match (parse "x |> f |> g").Syntax.e with | Syntax.EApp (outer, inner) -> ( check "outer argument is the inner application" (match outer.Syntax.e with Syntax.EVar "g" -> true | _ -> false); match inner.Syntax.e with | Syntax.EApp (f, arg) -> check "inner function is f" (match f.Syntax.e with Syntax.EVar "f" -> true | _ -> false); check "source is x" (match arg.Syntax.e with Syntax.EVar "x" -> true | _ -> false) | _ -> fail "shape" "expected an application on the left" ) | _ -> fail "shape" "expected an application" ); ( "let, lambda and conditional parse with spans", fun () -> match (parse "let f = fun n -> if n > 0 then n else - n in f 3").Syntax.e with | Syntax.ELet (name, _, body) -> check_equal_string "bound name" "f" name; check "body is an application" (match body.Syntax.e with Syntax.EApp _ -> true | _ -> false) | _ -> fail "shape" "expected a let expression" ); ( "tuples and record insertion parse", fun () -> match (parse "(1, 2, 3)").Syntax.e with | Syntax.ETuple [ _; _; _ ] -> check "tuple of three" true | _ -> fail "shape" "expected a tuple"; match (parse "{ customer = \"Ada\" }").Syntax.e with | Syntax.ERecord [ ("customer", _) ] -> check "record with one field" true | _ -> fail "shape" "expected a record" ); ( "field projection binds tighter than application", fun () -> match (parse "f o.total").Syntax.e with | Syntax.EApp (_, argument) -> check "argument is a projection" (match argument.Syntax.e with Syntax.EField _ -> true | _ -> false) | _ -> fail "shape" "expected an application" ); ( "comparison binds looser than conjunction", fun () -> match (parse "a && b = c").Syntax.e with | Syntax.EBinop (Syntax.And, _, right) -> check "right side is a comparison" (match right.Syntax.e with Syntax.EBinop (Syntax.Eq, _, _) -> true | _ -> false) | _ -> fail "shape" "expected a conjunction at the root" ); ( "unexpected character reports a span", fun () -> match parse_error "let x = @" with | None -> fail "lexical error" "expected a diagnostic" | Some diagnostic -> check_equal_string "message" ":1:9: error: unexpected character '@'" (Diagnostic.to_string diagnostic) ); ( "unterminated string reports the opening quote", fun () -> match parse_error "let s = \"abc" with | None -> fail "string" "expected a diagnostic" | Some diagnostic -> check_equal_string "message" ":1:9: error: unterminated string literal" (Diagnostic.to_string diagnostic); check_equal_string "span starts at the opening quote" "1:9-1:13" (Location.to_string diagnostic.Diagnostic.span) ); ( "unterminated comment reports a span", fun () -> match parse_error "1 (* comment" with | None -> fail "comment" "expected a diagnostic" | Some diagnostic -> check_equal_string "message" ":1:3: error: unterminated comment" (Diagnostic.to_string diagnostic); check_equal_string "span starts at the comment opener" "1:3-1:13" (Location.to_string diagnostic.Diagnostic.span) ); ( "integer literal overflow reports a span", fun () -> match parse_error "99999999999999999999999" with | None -> fail "overflow" "expected a diagnostic" | Some diagnostic -> check "message is non empty" (String.length diagnostic.Diagnostic.message > 0); check_equal_string "position" "1:1" (Location.pos_to_string diagnostic.Diagnostic.span.Location.start) ); ( "missing else reports the offending token", fun () -> match parse_error "if a then b" with | None -> fail "syntax" "expected a diagnostic" | Some diagnostic -> check_equal_string "message" ":1:12: error: syntax error: unexpected end of file" (Diagnostic.to_string diagnostic) ); ( "nested comments are skipped", fun () -> let parsed = parse "(* a (* b *) c *) 7" in check "the expression after the comment is parsed" (match parsed.Syntax.e with Syntax.EInt 7 -> true | _ -> false) ); ] let () = Test_harness.run_suite "location" location_cases; Test_harness.run_suite "ident" ident_cases; Test_harness.run_suite "diagnostic" diagnostic_cases; Test_harness.run_suite "parse" parse_cases; Printf.printf "%d cases, %d failures\n" (Test_harness.case_count ()) (Test_harness.failure_count ()); exit (if Test_harness.failure_count () = 0 then 0 else 1)