l4/pkg/ocaml/ocaml/contrib/typing/includeclass.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
   6 (*                                                                     *)
   7 (*  Copyright 1997 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: includeclass.ml 9236 2009-04-19 08:42:43Z xleroy $ *)
  14
  15 (* Inclusion checks for the class language *)
  16
  17 open Types
  18
  19 let class_types env cty1 cty2 =
  20   Ctype.match_class_types env cty1 cty2
  21
  22 let class_type_declarations env cty1 cty2 =
  23   Ctype.match_class_declarations env
  24     cty1.clty_params cty1.clty_type
  25     cty2.clty_params cty2.clty_type
  26
  27 let class_declarations env cty1 cty2 =
  28   match cty1.cty_new, cty2.cty_new with
  29     None, Some _ ->
  30       [Ctype.CM_Virtual_class]
  31   | _ ->
  32       Ctype.match_class_declarations env
  33         cty1.cty_params cty1.cty_type
  34         cty2.cty_params cty2.cty_type
  35
  36 open Format
  37 open Ctype
  38
  39 let include_err ppf =
  40   function
  41   | CM_Virtual_class ->
  42       fprintf ppf "A class cannot be changed from virtual to concrete"
  43   | CM_Parameter_arity_mismatch (ls, lp) ->
  44       fprintf ppf
  45         "The classes do not have the same number of type parameters"
  46   | CM_Type_parameter_mismatch trace ->
  47       fprintf ppf "@[%a@]"
  48       (Printtyp.unification_error false trace
  49         (function ppf ->
  50           fprintf ppf "A type parameter has type"))
  51         (function ppf ->
  52           fprintf ppf "but is expected to have type")
  53   | CM_Class_type_mismatch (cty1, cty2) ->
  54       fprintf ppf
  55        "@[The class type@;<1 2>%a@ is not matched by the class type@;<1 2>%a@]"
  56        Printtyp.class_type cty1 Printtyp.class_type cty2
  57   | CM_Parameter_mismatch trace ->
  58       fprintf ppf "@[%a@]"
  59       (Printtyp.unification_error false trace
  60         (function ppf ->
  61           fprintf ppf "A parameter has type"))
  62         (function ppf ->
  63           fprintf ppf "but is expected to have type")
  64   | CM_Val_type_mismatch (lab, trace) ->
  65       fprintf ppf "@[%a@]"
  66       (Printtyp.unification_error false trace
  67         (function ppf ->
  68           fprintf ppf "The instance variable %s@ has type" lab))
  69         (function ppf ->
  70           fprintf ppf "but is expected to have type")
  71   | CM_Meth_type_mismatch (lab, trace) ->
  72       fprintf ppf "@[%a@]"
  73       (Printtyp.unification_error false trace
  74         (function ppf ->
  75           fprintf ppf "The method %s@ has type" lab))
  76         (function ppf ->
  77           fprintf ppf "but is expected to have type")
  78   | CM_Non_mutable_value lab ->
  79       fprintf ppf
  80        "@[The non-mutable instance variable %s cannot become mutable@]" lab
  81   | CM_Non_concrete_value lab ->
  82       fprintf ppf
  83        "@[The virtual instance variable %s cannot become concrete@]" lab
  84   | CM_Missing_value lab ->
  85       fprintf ppf "@[The first class type has no instance variable %s@]" lab
  86   | CM_Missing_method lab ->
  87       fprintf ppf "@[The first class type has no method %s@]" lab
  88   | CM_Hide_public lab ->
  89      fprintf ppf "@[The public method %s cannot be hidden@]" lab
  90   | CM_Hide_virtual (k, lab) ->
  91       fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
  92   | CM_Public_method lab ->
  93       fprintf ppf "@[The public method %s cannot become private" lab
  94   | CM_Virtual_method lab ->
  95       fprintf ppf "@[The virtual method %s cannot become concrete" lab
  96   | CM_Private_method lab ->
  97       fprintf ppf "The private method %s cannot become public" lab
  98
  99 let report_error ppf = function
 100   |  [] -> ()
 101   | err :: errs ->
 102       let print_errs ppf errs =
 103          List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
 104       fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
 105
 106
 107