SessionFail should be hidden by default (links-lang#1202)

* SessionFail should be hidden by default

* retrigger ci

core/basicsettings.ml

@@ -54,7 +54,7 @@ module Sessions = struct
               |> sync)
 
   let expose_session_fail =
-    Settings.(flag "expose_session_fail" ~default:true
+    Settings.(flag "expose_session_fail" ~default:false
               |> synopsis "Exposes the SessionFail effect"
               |> depends Handlers.enabled
               |> depends exceptions_enabled

core/commonTypes.ml

@@ -51,6 +51,7 @@ module Restriction = struct
   type t =
     | Any
     | Base
+    | Numeric
     | Mono
     | Session
     | Effect
@@ -64,6 +65,10 @@ module Restriction = struct
     | Base -> true
     | _    -> false
 
+  let is_numeric = function
+    | Numeric -> true
+    | _    -> false
+
   let is_mono = function
     | Mono -> true
     | _    -> false
@@ -79,13 +84,15 @@ module Restriction = struct
   let to_string = function
     | Any     -> "Any"
     | Base    -> "Base"
+    | Numeric -> "Numeric"
     | Mono    -> "Mono"
     | Session -> "Session"
     | Effect  -> "Eff"
 
   let min l r =
     match l, r with
     | Any, Any         -> Some Any
+    | Numeric, Numeric -> Some Numeric
     | Mono, Mono       -> Some Mono
     | Session, Session -> Some Session
     | Effect, Effect   -> Some Effect
@@ -99,6 +106,7 @@ end
 (* Convenient aliases for constructing values *)
 let res_any     = Restriction.Any
 let res_base    = Restriction.Base
+let res_numeric = Restriction.Numeric
 let res_mono    = Restriction.Mono
 let res_session = Restriction.Session
 let res_effect  = Restriction.Effect
@@ -317,11 +325,11 @@ end
 
 module Constant = struct
   type t =
-    | Float  of float
-    | Int    of int
-    | Bool   of bool
-    | String of string
-    | Char   of char
+    | Float    of float
+    | Int      of int
+    | Bool     of bool
+    | String   of string
+    | Char     of char
     | DateTime of Timestamp.t
       [@@deriving show, ord]
 

core/parser.mly

@@ -158,6 +158,7 @@ let subkind_of p =
   | "Any"     -> Some (lin_any, res_any)
   | "Lin"     -> Some (lin_unl, res_any) (* for linear effect vars *)
   | "Base"    -> Some (lin_unl, res_base)
+  | "Numeric" -> Some (lin_unl, res_numeric) (* for numerics, should probably be subsubkind *)
   | "Session" -> Some (lin_any, res_session)
   | "Eff"     -> Some (default_effect_lin, res_effect)
   | sk        -> raise (ConcreteSyntaxError (pos p, "Invalid subkind: " ^ sk))

core/types.ml

@@ -799,6 +799,51 @@ module Base : Constraint = struct
   let make_type, make_row = make_restriction_transform Base
 end
 
+(* TODO Numeric type stuff, just yanked and pasted from above with only small changes *)
+module Numeric : Constraint = struct
+  open Restriction
+  open Primitive
+
+  module NumericPredicate = struct
+    class klass = object
+      inherit type_predicate as super
+
+      method! point_satisfies f vars point =
+        match Unionfind.find point with
+        | Recursive _ -> false
+        | _ -> super#point_satisfies f vars point
+
+      method! type_satisfies vars = function
+        (* Unspecified kind *)
+        | Not_typed -> assert false
+        | Var _ | Recursive _ | Closed ->
+           failwith ("[3] freestanding Var / Recursive / Closed not implemented yet (must be inside Meta)")
+        | Alias _  as t  -> super#type_satisfies vars t
+        | (Application _ | RecursiveApplication _) -> false
+        | Meta _ as t  -> super#type_satisfies vars t
+        (* Type *)
+        | Primitive (Int | Float) -> true
+        | Primitive _ -> false
+        | (Function _ | Lolli _ | Record _ | Variant _ | Table _ | Lens _ | ForAll (_::_, _)) -> false
+        | ForAll ([], t) -> super#type_satisfies vars t
+        (* Effect *)
+        | Effect _ as t -> super#type_satisfies vars t
+        | Operation _ -> failwith "TODO types.ml/766"
+        (* Row *)
+        | Row _ as t -> super#type_satisfies vars t
+        (* Presence *)
+        | Absent -> true
+        | Present _ as t -> super#type_satisfies vars t
+        (* Session *)
+        | Input _ | Output _ | Select _ | Choice _ | Dual _ | End -> false
+    end
+  end
+
+  let type_satisfies, row_satisfies = make_restriction_predicate (module NumericPredicate) Numeric false
+  let can_type_be, can_row_be = make_restriction_predicate (module NumericPredicate) Numeric true
+  let make_type, make_row = make_restriction_transform Numeric
+end
+
 (* unl type stuff *)
 module Unl : Constraint = struct
   class unl_predicate = object(o)
@@ -994,6 +1039,7 @@ let get_restriction_constraint : Restriction.t -> (module Constraint) option =
   let open Restriction in function
   | Any | Effect -> None
   | Base -> Some (module Base)
+  | Numeric -> Some (module Numeric)
   | Session -> Some (module Session)
   | Mono -> Some (module Mono)
 
@@ -2395,6 +2441,7 @@ struct
        | (Linearity.Unl, Restriction.Any)     -> ""
        | (Linearity.Any, Restriction.Any)     -> "Any"
        | (Linearity.Unl, Restriction.Base)    -> Restriction.to_string res_base
+       | (Linearity.Unl, Restriction.Numeric) -> Restriction.to_string res_numeric
        | (Linearity.Any, Restriction.Session) -> Restriction.to_string res_session
        | (Linearity.Unl, Restriction.Effect)  -> Restriction.to_string res_effect
        | (l, r) -> full (l, r)
@@ -2411,6 +2458,8 @@ struct
       | PrimaryKind.Type, (Linearity.Unl, Restriction.Any) -> ""
       | PrimaryKind.Type, (Linearity.Unl, Restriction.Base) ->
          Restriction.to_string res_base
+      | PrimaryKind.Type, (Linearity.Unl, Restriction.Numeric) ->
+         Restriction.to_string res_numeric
       | PrimaryKind.Type, (Linearity.Any, Restriction.Session) ->
          Restriction.to_string res_session
       | PrimaryKind.Type, sk ->
@@ -3498,6 +3547,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct
        | (L.Unl, R.Any)     -> if is_eff && lincont_enabled then constant "Lin" else Empty (* (1) see above *)
        | (L.Any, R.Any)     -> if is_eff && lincont_enabled then Empty else constant "Any"
        | (L.Unl, R.Base)    -> constant @@ R.to_string res_base
+       | (L.Unl, R.Numeric) -> constant @@ R.to_string res_numeric
        | (L.Any, R.Session) -> constant @@ R.to_string res_session
        | (L.Unl, R.Effect)  -> constant @@ R.to_string res_effect (* control-flow-linearity may also need changing this *)
        | _ -> full_name
@@ -3535,6 +3585,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct
                  match subknd with
                  | L.Unl, R.Any     -> assert false
                  | L.Unl, R.Base    -> StringBuffer.write buf (R.to_string res_base)
+                 | L.Unl, R.Numeric -> StringBuffer.write buf (R.to_string res_numeric)
                  | L.Any, R.Session -> StringBuffer.write buf (R.to_string res_session)
                  | subknd ->
                     let policy = Policy.set_kinds Policy.Full (Context.policy ctx) in

core/types.mli

@@ -198,6 +198,7 @@ module type Constraint = sig
 end
 
 module Base : Constraint
+module Numeric : Constraint
 module Unl : Constraint
 module Session : Constraint
 module Mono : Constraint

links.opam

@@ -23,8 +23,8 @@ doc: "https://links-lang.org/quick-help.html"
 bug-reports: "https://github.com/links-lang/links/issues"
 depends: [
   "dune" {>= "2.7"}
-  "ocaml" { >= "5.1.0"}
-  "dune-configurator" { >= "3.8"}
+  "ocaml" {":" >= "5.1.1"}
+  "dune-configurator" {":" >= "3.8"}
   "ppx_deriving"
   "ppx_deriving_yojson" {>= "3.3"}
   "base64"

numeric.links

@@ -0,0 +1,8 @@
+sig id_num : (a::Numeric) -> a::Numeric
+var id_num = fun (x) {x};
+
+sig add : (a::Numeric, a::Numeric) -> a::Numeric
+var add = fun (x,y) {x + y};
+
+
+add(1, 2)