1. camlspotter
  2. olfend

Source

olfend / rawtype.ml

open Spotlib.Spot
open Sexplib.Conv
open Sexplib.Sexp

module StringSet = Set.Make(String) (* CR jfuruse: to be moved to somewhere more general *)

module Type = struct
  (* type expression, or mono type *)
  type t = 
    | Var    of string          (* lev 3 *)
    | Arrow  of t * t           (* lev 1, rassoc *)
    | Tuple  of t list          (* lev 2, noassoc: a * b * c <> (a * b) * c or a * (b * c) *)
    | Constr of string * t list (* lev2, noassoc *)

  type typ = t

  let rec vars = 
    let open StringSet in
    function
      | Var s -> one s
      | Arrow (t1, t2) -> union (vars t1) (vars t2)
      | Tuple ts | Constr (_, ts) -> unions (List.map vars ts)
  
  let rec sexp_of_t t = match t with
    | Var n -> Atom n
    | Arrow (t1, (Arrow _ as t2)) ->
        begin match sexp_of_t t2 with
        | List (Atom "->" :: rest) -> List (Atom "->" :: sexp_of_t t1 :: rest)
        | _ -> assert false
        end
    | Arrow (t1, t2) ->
        List [Atom "->"; sexp_of_t t1; sexp_of_t t2]
    | Tuple ts ->
        List (Atom "*" :: List.map sexp_of_t ts)
    | Constr (p, []) -> Atom p
    | Constr (p, ts) -> List (Atom p :: List.map sexp_of_t ts)
    
  let rec t_of_sexp = function
    | Atom "" -> assert false
    | Atom n when n.[0] = '\'' -> Var n
    | Atom p -> Constr (p, [])
    | List (Atom "->" :: ts) ->
        let ts = List.map t_of_sexp ts in
        let rec f = function
          | [] -> assert false
          | [x] -> x
          | x::xs -> Arrow (x, f xs)
        in
        f ts
    | List (Atom "*" :: ts) -> Tuple (List.map t_of_sexp ts)
    | List (Atom p :: ts) -> Constr (p, List.map t_of_sexp ts)
    | List _ -> assert false

  let rec ppr = 
    let open Treeprint.Printer in 
    let open Treeprint.Printer.OCaml in 
    function
      | Var name -> string (Printf.sprintf "'%s" name)
      | Arrow (t1, t2) -> ppr t1 ^-> ppr t2
      | Tuple ts -> list 1.0 (space ++ string "*" ++ space) (List.map ppr ts)
      | Constr (name, []) -> string name
      | Constr (name, ts) -> list 1.0 space (string name :: List.map ppr ts)

  include Treeprint.Printer.MakeDrivers(struct type t = typ let ppr = ppr end)
end

module Poly = struct
  type t = Poly of string list * Type.t
  type poly = t

  let sexp_of_t = function
    | Poly ([], t) -> Type.sexp_of_t t
    | Poly (vs, t) -> List [ Atom "forall"; 
                             List (List.map sexp_of_string vs);
                             Type.sexp_of_t t ]

  let t_of_sexp = function
    | List [Atom "forall"; List vars; t] ->
        Poly (List.map string_of_sexp vars, Type.t_of_sexp t)
    | List [Atom "forall"; _; _] -> assert false
    | t -> 
      Poly ([], Type.t_of_sexp t)

  let ppr (Poly (vars, ty)) = 
    let open Treeprint.Printer in 
    match vars with
    | [] -> Type.ppr ty
    | _ -> list 0.9 space [string "forall"; list 1.0 space (List.map (fun v -> string (Printf.sprintf "'%s" v)) vars) ; string "."; Type.ppr ty]

  include Treeprint.Printer.MakeDrivers(struct type t = poly let ppr = ppr end)
end

module Decl = struct
  type variant_args = string * Type.t list with sexp
  type record_field = string * Type.t with sexp
  
  type kind = 
    | Variant of variant_args list
    | Record  of record_field list
    | Alias   of Type.t
    | Abstract
  
  let sexp_of_kind = function
    | Variant xs -> List (Atom "Variant" :: List.map sexp_of_variant_args xs)
    | Record  xs -> List (Atom "Record" :: List.map sexp_of_record_field xs)
    | Alias   t  -> List [Atom "Alias"; Type.sexp_of_t t ]
    | Abstract   -> List []
  
  let kind_of_sexp = function
    | List [] -> Abstract
    | List (Atom "Variant" :: xs) -> Variant (List.map variant_args_of_sexp xs)
    | List (Atom "Record" :: xs) -> Record (List.map record_field_of_sexp xs)
    | List [Atom "Alias"; t] -> Alias (Type.t_of_sexp t)
    | _ -> assert false
  
  type t = {
    name   : string;
    params : string list;
    kind   : kind 
  }
  
  let sexp_of_t { name; params; kind } = 
    List [ Atom name;
           sexp_of_list sexp_of_string params;
           sexp_of_kind kind ]
  
  let t_of_sexp = function
    | List [ Atom name; params; kind ] ->
        { name; params = list_of_sexp string_of_sexp params; kind= kind_of_sexp kind }
    | sexp -> Format.eprintf "error: %a@." Sexplib.Sexp.pp_hum sexp; assert false
end  
         
include Type