Redefine Sugartypes as ordinary variants

This patch changes AST definitions in Sugartypes from polymorphic
variants to ordinary variants.  Some constructors are renamed to avoid
name clashes.  Others are placed inside modules.  Common datatypes used
throughout the compiler are placed in a new CommonTypes module.
Operators are placed in a separate module to avoid import cycles with
lens code.

Closes #487

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,125 @@
+module Linearity = struct
+  type t = Any | Unl
+    [@@deriving eq,show]
+
+  let is_any = function
+    | Any -> true
+    | _   -> false
+
+  let is_nonlinear = function
+    | Unl -> true
+    | _   -> false
+
+  let to_string = function
+    | Any -> "Any"
+    | Unl -> "Unl"
+end
+
+(* Convenient aliases for constructing values *)
+let lin_any = Linearity.Any
+let lin_unl = Linearity.Unl
+
+module DeclaredLinearity = struct
+  type t = Lin | Unl
+    [@@deriving show]
+
+  let is_linear = function
+    | Lin -> true
+    | _   -> false
+
+  let is_nonlinear = function
+    | Unl -> true
+    | _   -> false
+end
+
+(* Convenient aliases for constructing values *)
+let dl_lin = DeclaredLinearity.Lin
+let dl_unl = DeclaredLinearity.Unl
+
+module Restriction = struct
+  type t =
+    | Any
+    | Base
+    | Session
+    | Effect
+    [@@deriving eq,show]
+
+  let is_any = function
+    | Any -> true
+    | _   -> false
+
+  let is_base = function
+    | Base -> true
+    | _    -> false
+
+  let is_session = function
+    | Session -> true
+    | _       -> false
+
+  let is_effect = function
+    | Effect -> true
+    | _      -> false
+
+  let to_string = function
+    | Any     -> "Any"
+    | Base    -> "Base"
+    | Session -> "Session"
+    | Effect  -> "Eff"
+end
+
+(* Convenient aliases for constructing values *)
+let res_any     = Restriction.Any
+let res_base    = Restriction.Base
+let res_session = Restriction.Session
+let res_effect  = Restriction.Effect
+
+module PrimaryKind = struct
+  type t =
+    | Type
+    | Row
+    | Presence
+    [@@deriving show,eq]
+
+  let to_string = function
+    | Type     -> "Type"
+    | Row      -> "Row"
+    | Presence -> "Presence"
+end
+
+(* Convenient aliases for constructing values *)
+let pk_type     = PrimaryKind.Type
+let pk_row      = PrimaryKind.Row
+let pk_presence = PrimaryKind.Presence
+
+module Location = struct
+  type t = Client | Server | Native | Unknown
+    [@@deriving show]
+
+  let is_client = function
+    | Client -> true
+    | _      -> false
+
+  let is_server = function
+    | Server -> true
+    | _      -> false
+
+  let is_native = function
+    | Native -> true
+    | _      -> false
+
+  let is_unknown = function
+    | Unknown -> true
+    | _      -> false
+
+  let to_string = function
+    | Client -> "client"
+    | Server -> "server"
+    | Native -> "native"
+    | Unknown -> "unknown"
+end
+
+(* Convenient aliases for constructing values *)
+let loc_client  = Location.Client
+let loc_server  = Location.Server
+let loc_native  = Location.Native
+let loc_unknown = 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 (lin_any, res_any)) 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