Remove polymorphic variants using module namespacing

bin/repl.ml

@@ -2,6 +2,7 @@ open Links_core
 open Utility
 open List
 open Sugartypes
+open CommonTypes
 
 module BS = Basicsettings
 
@@ -227,11 +228,11 @@ let evaluate_parse_result envs parse_result =
                   | Some (finfo, _, None, location) ->
                     let v =
                       match location with
-                      | `Server | `Unknown ->
+                      | Location.Server | Location.Unknown ->
                         `FunctionPtr (var, None)
-                      | `Client ->
+                      | Location.Client ->
                         `ClientFunction (Js.var_name_binder (var, finfo))
-                      | `Native -> assert false in
+                      | Location.Native -> assert false in
                     let t = Var.info_type finfo in v, t
                   | _ -> assert false
                 in

core/chaser.ml

@@ -1,5 +1,6 @@
 open Utility
 open ModuleUtils
+open Sugartypes
 
 (* Helper functions *)
 (* Helper function: given top-level module name, maps to expected filename *)
@@ -37,15 +38,15 @@ object(self)
     {< shadow_table = shadow_table >}
 
   method! bindingnode = function
-    | `QualifiedImport ns ->
+    | QualifiedImport ns ->
         (* Try to resolve the import; if not, add to ICs list *)
         let lookup_ref = List.hd ns in
         (try
            let _ = StringMap.find lookup_ref shadow_table in
            self
          with
            _ -> self#add_import_candidate lookup_ref)
-    | `Module (n, bs) ->
+    | Module (n, bs) ->
         let new_path = path @ [n] in
         let fqn = lst_to_path new_path in
         let o = self#bind_shadow n fqn in
@@ -71,7 +72,7 @@ let rec add_module_bindings deps dep_map =
     | [module_name]::ys ->
       (try
         let (bindings, _) = StringMap.find module_name dep_map in
-        Sugartypes.with_dummy_pos (`Module (module_name, bindings)) :: (add_module_bindings ys dep_map)
+        with_dummy_pos (Module (module_name, bindings)) :: (add_module_bindings ys dep_map)
       with Notfound.NotFound _ ->
         (failwith (Printf.sprintf "Trying to find %s in dep map containing keys: %s\n"
           module_name (print_list (List.map fst (StringMap.bindings dep_map))))));
@@ -109,7 +110,7 @@ let add_dependencies module_prog =
   let sorted_deps = Graph.topo_sort_sccs deps in
   (* Each entry should be *precisely* one element (otherwise we have cycles) *)
   assert_no_cycles sorted_deps;
-  (* Now, build up binding list where each opened dependency is mapped to a `Module containing
+  (* Now, build up binding list where each opened dependency is mapped to a Module containing
    * its list of inner bindings. *)
   (* FIXME: This isn't reassigning positions! What we'll want is to retain the positions, but modify
    * the position data type to keep track of the module filename we're importing from. *)

core/checkXmlQuasiquotes.ml

@@ -16,19 +16,19 @@ let check mode pos e =
 
       method! phrase = fun ({node=e; pos} as phrase) ->
         match e with
-        | `Xml (_, _, _, children) ->
+        | Xml (_, _, _, children) ->
           o#list (fun o -> o#phrase) children
-        | `FormBinding _ ->
+        | FormBinding _ ->
           if mode <> `Formlet then
             {< error = Some (`FormletBinding, pos) >}
           else
             super#phrase phrase
-        | `FormletPlacement _ ->
+        | FormletPlacement _ ->
           if mode <> `Page then
             {< error = Some (`FormletPlacement, pos) >}
           else
             super#phrase phrase
-        | `PagePlacement _ ->
+        | PagePlacement _ ->
           if mode <> `Page then
             {< error = Some (`PagePlacement, pos) >}
           else
@@ -72,18 +72,18 @@ object (o)
 
   method! phrase = fun ({node=e; pos} as phrase) ->
     match e with
-    | `Xml _ when mode = `Quasi ->
+    | Xml _ when mode = `Quasi ->
       super#phrase phrase
-    | `Xml _ when mode = `Exp ->
+    | Xml _ when mode = `Exp ->
       check `Xml pos e;
       o#phrase_with `Quasi phrase
-    | `Formlet (body, yields) when mode = `Exp ->
+    | Formlet (body, yields) when mode = `Exp ->
       check `Formlet pos body.node;
       (o#phrase_with `Quasi body)#phrase yields
-    | `Page body when mode = `Exp ->
+    | Page body when mode = `Exp ->
       check `Page pos body.node;
       o#phrase_with `Quasi body
-    | (`Formlet _ | `Page _) when mode = `Quasi ->
+    | (Formlet _ | Page _) when mode = `Quasi ->
       (* The parser should prevent this from ever happening *)
       raise (Errors.SugarError (pos, "Malformed quasiquote (internal error)"))
     | _ when mode = `Quasi ->

core/closures.ml

@@ -1,4 +1,5 @@
 open Utility
+open CommonTypes
 
 type freevars = {termvars: (Ir.binder list) ; typevars: Types.quantifier list} [@@deriving show]
 type fenv = freevars IntMap.t [@@deriving show]
@@ -585,15 +586,15 @@ struct
           let newvar = Types.fresh_raw_variable () in
           let make_new_type_variable () = Unionfind.fresh (`Var (newvar, subkind, `Rigid)) in
           let new_meta_var, updated_maps = match primary_kind with
-            | `Type ->
+            | PrimaryKind.Type ->
               let new_type_variable = make_new_type_variable () in
               let t = `MetaTypeVar new_type_variable in
               (`Type new_type_variable, (IntMap.add typevar t type_map, row_map, presence_map))
-            | `Row ->
+            | PrimaryKind.Row ->
               let new_type_variable = make_new_type_variable () in
               let r = (Types.empty_field_env, new_type_variable, false) in
               (`Row new_type_variable, (type_map, IntMap.add typevar r row_map, presence_map))
-            | `Presence ->
+            | PrimaryKind.Presence ->
               let new_type_variable = make_new_type_variable () in
               let p = `Var new_type_variable in
               (`Presence new_type_variable, (type_map, row_map, IntMap.add typevar p presence_map)) in

core/commonTypes.ml

@@ -0,0 +1,111 @@
+module Linearity = struct
+  type t = Any | Unl
+    [@@deriving eq,show]
+
+  let isAny lin = lin == Any
+  let isUnl lin = lin == Unl
+
+  let string_of = function
+    | Any -> "Any"
+    | Unl -> "Unl"
+end
+
+(* Convenient aliases for constructing values *)
+let linUnl = Linearity.Unl
+let linAny = Linearity.Any
+
+module DeclaredLinearity = struct
+  type t = Lin | Unl
+    [@@deriving show]
+
+  let isLin lin = lin == Lin
+  let isUnl lin = lin == Unl
+end
+
+(* Convenient aliases for constructing values *)
+let dlLin = DeclaredLinearity.Lin
+let dlUnl = DeclaredLinearity.Unl
+
+module Restriction = struct
+  type t =
+    | Any
+    | Base
+    | Session
+    | Effect
+    [@@deriving eq,show]
+
+  let isAny = function
+    | Any -> true
+    | _   -> false
+
+  let isBase = function
+    | Base -> true
+    | _    -> false
+
+  let isSession = function
+    | Session -> true
+    | _       -> false
+
+  let string_of = function
+    | Any     -> "Any"
+    | Base    -> "Base"
+    | Session -> "Session"
+    | Effect  -> "Eff"
+end
+
+(* Convenient aliases for constructing values *)
+let resAny     = Restriction.Any
+let resBase    = Restriction.Base
+let resSession = Restriction.Session
+let resEffect  = Restriction.Effect
+
+module PrimaryKind = struct
+  type t =
+    | Type
+    | Row
+    | Presence
+    [@@deriving show,eq]
+
+  let string_of = function
+    | Type -> "Type"
+    | Row -> "Row"
+    | Presence -> "Presence"
+end
+
+(* Convenient aliases for constructing values *)
+let pkType     = PrimaryKind.Type
+let pkRow      = PrimaryKind.Row
+let pkPresence = PrimaryKind.Presence
+
+module Location = struct
+  type t = Client | Server | Native | Unknown
+    [@@deriving show]
+
+  let isClient = function
+    | Client -> true
+    | _      -> false
+
+  let isServer = function
+    | Server -> true
+    | _      -> false
+
+  let isNative = function
+    | Native -> true
+    | _      -> false
+
+  let isUnknown = function
+    | Unknown -> true
+    | _      -> false
+
+  let string_of = function
+    | Client -> "client"
+    | Server -> "server"
+    | Native -> "native"
+    | Unknown -> "unknown"
+end
+
+(* Convenient aliases for constructing values *)
+let locClient  = Location.Client
+let locServer  = Location.Server
+let locNative  = Location.Native
+let locUnknown = Location.Unknown

core/compilePatterns.ml

@@ -8,6 +8,7 @@
   to adjust our intermediate language.
 *)
 
+open CommonTypes
 open Utility
 open Ir
 
@@ -74,10 +75,10 @@ let lookup_name name (nenv, _tenv, _eff, _penv) =
 
 let lookup_effects (_nenv, _tenv, eff, _penv) = eff
 
-let rec desugar_pattern : Ir.scope -> Sugartypes.pattern -> pattern * raw_env =
+let rec desugar_pattern : Ir.scope -> Sugartypes.Pattern.with_pos -> pattern * raw_env =
   fun scope {Sugartypes.node=p; Sugartypes.pos} ->
-    let pp = desugar_pattern scope in
-    let empty = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (`Any, `Any)) in
+    let desugar_pat = desugar_pattern scope in
+    let empty = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (linAny, resAny)) in
     let (++) (nenv, tenv, _) (nenv', tenv', eff') = (NEnv.extend nenv nenv', TEnv.extend tenv tenv', eff') in
     let fresh_binder (nenv, tenv, eff) bndr =
       assert (Sugartypes.binder_has_type bndr);
@@ -86,65 +87,66 @@ let rec desugar_pattern : Ir.scope -> Sugartypes.pattern -> pattern * raw_env =
       let xb, x = Var.fresh_var (t, name, scope) in
       xb, (NEnv.bind nenv (name, x), TEnv.bind tenv (x, t), eff)
     in
+      let open Sugartypes.Pattern in
       match p with
-        | `Any -> `Any, empty
-        | `Nil -> `Nil, empty
-        | `Cons (p, ps) ->
-            let p, env = pp p in
-            let ps, env' = pp ps in
+        | Any -> `Any, empty
+        | Nil -> `Nil, empty
+        | Cons (p, ps) ->
+            let p, env = desugar_pat p in
+            let ps, env' = desugar_pat ps in
               `Cons (p, ps), env ++ env'
-        | `List [] -> pp (Sugartypes.with_pos pos `Nil)
-        | `List (p::ps) ->
-            let p, env = pp p in
-            let ps, env' = pp (Sugartypes.with_pos pos (`List ps)) in
+        | List [] -> desugar_pat (Sugartypes.with_pos pos Nil)
+        | List (p::ps) ->
+            let p, env = desugar_pat p in
+            let ps, env' = desugar_pat (Sugartypes.with_pos pos (List ps)) in
               `Cons (p, ps), env ++ env'
-        | `Variant (name, None) -> `Variant (name, `Any), empty
-        | `Variant (name, Some p) ->
-            let p, env = pp p in
+        | Variant (name, None) -> `Variant (name, `Any), empty
+        | Variant (name, Some p) ->
+            let p, env = desugar_pat p in
             `Variant (name, p), env
-        | `Effect (name, ps, k) ->
+        | Effect (name, ps, k) ->
            let ps, env =
              List.fold_right
                (fun p (ps, env) ->
-                 let p', env' = pp p in
+                 let p', env' = desugar_pat p in
                  (p' :: ps, env ++ env'))
                ps ([], empty)
            in
-           let k, env' = pp k in
+           let k, env' = desugar_pat k in
            `Effect (name, ps, k), env ++ env'
-        | `Negative names -> `Negative (StringSet.from_list names), empty
-        | `Record (bs, p) ->
+        | Negative names -> `Negative (StringSet.from_list names), empty
+        | Record (bs, p) ->
             let bs, env =
               List.fold_right
                 (fun (name, p) (bs, env) ->
-                   let p, env' = pp p in
+                   let p, env' = desugar_pat p in
                      StringMap.add name p bs, env ++ env')
                 bs
                 (StringMap.empty, empty) in
             let p, env =
               match p with
                 | None -> None, env
                 | Some p ->
-                    let p, env' = pp p in
+                    let p, env' = desugar_pat p in
                       Some p, env ++ env'
             in
               `Record (bs, p), env
-        | `Tuple ps ->
+        | Tuple ps ->
             let bs = mapIndex (fun p i -> (string_of_int (i+1), p)) ps in
-              pp (Sugartypes.with_pos pos (`Record (bs, None)))
-        | `Constant constant ->
+              desugar_pat (Sugartypes.with_pos pos (Record (bs, None)))
+        | Constant constant ->
             `Constant constant, empty
-        | `Variable b ->
+        | Variable b ->
             let xb, env = fresh_binder empty b in
               `Variable xb, env
-        | `As (b, p) ->
+        | As (b, p) ->
             let xb, env = fresh_binder empty b in
-            let p, env' = pp p in
+            let p, env' = desugar_pat p in
               `As (xb, p), env ++ env'
-        | `HasType (p, (_, Some t)) ->
-            let p, env = pp p in
+        | HasType (p, (_, Some t)) ->
+            let p, env = desugar_pat p in
               `HasType (p, t), env
-        | `HasType (_, (_, None)) -> assert false
+        | HasType (_, (_, None)) -> assert false
 
 type raw_bound_computation = raw_env -> computation
 type bound_computation = env -> computation