package gospel

  1. Overview
  2. Docs

Source file utils.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
(**************************************************************************)
(*                                                                        *)
(*  GOSPEL -- A Specification Language for OCaml                          *)
(*                                                                        *)
(*  Copyright (c) 2018- The VOCaL Project                                 *)
(*                                                                        *)
(*  This software is free software, distributed under the MIT license     *)
(*  (as described in file LICENSE enclosed).                              *)
(**************************************************************************)

open Ppxlib

let rec split_at_f f = function
  | [] -> ([], [])
  | x :: xs when f x ->
      let xs', ys' = split_at_f f xs in
      (x :: xs', ys')
  | l -> ([], l)

let rec split_at_i i = function
  | [] -> ([], [])
  | l when i <= 0 -> ([], l)
  | x :: xs ->
      let xs', ys' = split_at_i (pred i) xs in
      (x :: xs', ys')

module Fmt = struct
  include Fmt

  let list ?(first = nop) ?(last = nop) ?sep pp_v ppf l =
    if List.length l = 0 then ()
    else pf ppf "%a@[%a@]%a" first () (list ?sep pp_v) l last ()

  let pp = pf
  let full ppf _ = pf ppf ".@ "
  let arrow ppf _ = pf ppf " ->@ "
  let star ppf _ = pf ppf " *@ "
  let newline ppf _ = pf ppf "@\n"
  let lparens ppf _ = pf ppf "@[<1>("
  let rparens ppf _ = pf ppf ")@]"
  let lbracket ppf _ = pf ppf "@[<1>["
  let rbracket ppf _ = pf ppf "]@]"
  let lbrace ppf _ = pf ppf "@[<1>{"
  let rbrace ppf _ = pf ppf "}@]"
end

module Sstr = Set.Make (String)

exception TypeCheckingError of string
exception NotSupported of string
exception Located of Location.t * exn

let error ~loc e = raise (Located (loc, e))
let check ~loc c exn = if not c then error ~loc exn
let error_report ~loc s = error ~loc (TypeCheckingError s)
let check_report ~loc c s = check ~loc c (TypeCheckingError s)
let not_supported ~loc s = error ~loc (NotSupported s)

let () =
  let open Location.Error in
  register_error_of_exn (function
    | Located (loc, exn) ->
        of_exn exn |> Option.map (fun t -> Location.Error.update_loc t loc)
    | TypeCheckingError s ->
        Fmt.kstr
          (fun str -> Some (make ~loc:Location.none ~sub:[] str))
          "Type checking error: %s" s
    | NotSupported s ->
        Fmt.kstr
          (fun str -> Some (make ~loc:Location.none ~sub:[] str))
          "Not supported: %s" s
    | _ -> None)