open Location exception Usage let () = List.iter (fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)]) Builtin.types let (source,input_channel) = match Array.length Sys.argv with | 1 -> ("",stdin) | 2 -> let s = Sys.argv.(1) in (s, open_in s) | _ -> raise Usage let input = Stream.of_channel input_channel let ppf = Format.std_formatter let prog () = try Parser.prog input with | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e)) let print_norm ppf d = Types.Print.print_descr ppf (Types.normalize d) let rec print_exn ppf = function | Location ((i,j), exn) -> if source = "" then Format.fprintf ppf "Error at chars %i-%i@\n" i j else ( let (l1,c1) = Location.get_line_number source i and (l2,c2) = Location.get_line_number source j in if l1 = l2 then Format.fprintf ppf "Error at line %i (chars %i-%i)@\n" l1 c1 c2 else Format.fprintf ppf "Error at lines %i (char %i) - %i (char %i)@\n" l1 c1 l2 c2 ); print_exn ppf exn | Typer.WrongLabel (t,l) -> Format.fprintf ppf "Wrong record selection: the label %s@\n" (Types.label_name l); Format.fprintf ppf "applied to an expression of type %a@\n" print_norm t | Typer.MultipleLabel l -> Format.fprintf ppf "Multiple occurences for the record label %s@\n" (Types.label_name l); | Typer.ShouldHave (t,msg) -> Format.fprintf ppf "This expression should have type %a@\n%s@\n" print_norm t msg | Typer.Constraint (s,t,msg) -> Format.fprintf ppf "This expression should have type %a@\n" print_norm t; Format.fprintf ppf "but its infered type is: %a@\n" print_norm s; Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n" Types.Print.print_sample (Types.Sample.get (Types.diff s t)); Format.fprintf ppf "%s@\n" msg | Typer.NonExhaustive t -> Format.fprintf ppf "This pattern matching is not exhaustive@\n"; Format.fprintf ppf "Residual type: %a@\n" print_norm t; Format.fprintf ppf "Sample value: %a@\n" Types.Print.print_sample (Types.Sample.get t) | Typer.UnboundId x -> Format.fprintf ppf "Unbound identifier %s@\n" x | exn -> Format.fprintf ppf "%s@\n" (Printexc.to_string exn) let debug = function | `Filter (t,p) -> Format.fprintf ppf "[DEBUG:filter]@\n"; let t = Typer.typ t and p = Typer.pat p in let f = Patterns.filter (Types.descr t) p in List.iter (fun (x,t) -> Format.fprintf ppf " x:%a@\n" print_norm (Types.descr t)) f | `Accept p -> Format.fprintf ppf "[DEBUG:accept]@\n"; let p = Typer.pat p in let t = Patterns.accept p in Format.fprintf ppf " %a@\n" Types.Print.print t | `Compile (t,pl) -> Format.fprintf ppf "[DEBUG:compile]@\n"; let t = Typer.typ t and pl = List.map Typer.pat pl in let pl = Array.of_list (List.map (fun p -> Patterns.Compile.normal (Patterns.descr p)) pl) in Patterns.Compile.show ppf (Types.descr t) pl | _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n" let phrase ph = match ph.descr with | Ast.EvalStatement e -> let (fv,e) = Typer.expr e in let t = Typer.type_check Typer.Env.empty e Types.any true in Format.fprintf ppf "|- %a@\n" print_norm t; let v = Value.eval Value.empty_env e in Format.fprintf ppf "=> %a@\n" Value.print v | Ast.TypeDecl _ -> () | Ast.Debug l -> debug l | _ -> assert false let () = try let p = prog () in let type_decls = List.fold_left (fun accu ph -> match ph.descr with | Ast.TypeDecl (x,t) -> (x,t) :: accu | _ -> accu ) [] p in Typer.register_global_types type_decls; List.iter phrase p with | (Failure _ | Not_found) as e -> raise e (* To get the ocamlrun stack trace *) | exn -> print_exn ppf exn