Clean up Scheme & SmartPrint

src/typing/scheme.ml

@@ -168,23 +168,45 @@ and abstract2 ~loc (ctx_p1, ty_p1, cnstrs_p1) (ctx_p2, ty_p2, cnstrs_p2) (ctx_c,
   | ctx, Type.Arrow (Type.Tuple [ty_p1; ty_p2], drty_c), cnstrs -> ctx, (ty_p1, ty_p2, drty_c), cnstrs
   | _ -> assert false
 
+let beautify_ty_scheme ty_sch = 
+  let sbst = Type.beautifying_subst () in
+  subst_ty_scheme sbst ty_sch
+
+let beautify_dirty_scheme drty_sch = 
+  let sbst = Type.beautifying_subst () in
+  let _, (_, ds, _) = pos_neg_dirtyscheme drty_sch in
+  ignore (Common.map sbst.Type.dirt_param ds);
+  subst_dirty_scheme sbst drty_sch
+
+let extend_non_poly (ts, ds, rs) skeletons =
+  let add_skel skel new_ts =
+    if List.exists (fun t -> List.mem t ts) skel then
+    skel @ new_ts else new_ts
+  in
+  let ts = List.fold_right add_skel skeletons ts in
+  (Common.uniq ts, ds, rs)
+
+let skeletons_non_poly_scheme (ctx, _, cnstrs) =
+  let skeletons = Constraints.skeletons cnstrs in
+  let non_poly = Trio.flatten_map (fun (x, t) -> let pos, neg = Type.pos_neg_params Tctx.get_variances t in pos @@@ neg) ctx in
+  let non_poly = extend_non_poly non_poly skeletons in
+  skeletons, non_poly
+
 let print_context ctx ppf =
   let print_binding (x, t) ppf =
     Print.print ppf "%t : %t" (Untyped.Variable.print x) (Type.print_ty t)
   in
   Print.sequence ", " print_binding ctx ppf
 
 let print_ty_scheme ty_sch ppf =
-  let sbst = Type.beautifying_subst () in
-  let (ctx, ty, cnstrs) = subst_ty_scheme sbst ty_sch in
+  let (ctx, ty, cnstrs) = beautify_ty_scheme ty_sch in
   Print.print ppf "%t |- %t | %t"
     (print_context ctx)
     (Type.print_ty ty)
     (Constraints.print cnstrs)
 
 let print_dirty_scheme ty_sch ppf =
-  let sbst = Type.beautifying_subst () in
-  let (ctx, (ty, drt), cnstrs) = subst_dirty_scheme sbst ty_sch in
+  let (ctx, (ty, drt), cnstrs) = beautify_dirty_scheme ty_sch in
   Print.print ppf "%t |- %t ! %t | %t"
     (print_context ctx)
     (Type.print_ty ty)

src/typing/scheme.mli

@@ -26,9 +26,8 @@ val clean_dirty_scheme : loc:Location.t -> dirty_scheme -> dirty_scheme
 val finalize_pattern_scheme : loc:Location.t -> context -> Type.ty -> change list -> ty_scheme
 val add_to_top : loc:Location.t -> context -> Constraints.t -> (dirty_scheme -> dirty_scheme)
 val normalize_context : loc:Location.t -> ty_scheme -> ty_scheme
-val subst_ty_scheme : Type.substitution -> ty_scheme -> ty_scheme
-val subst_dirty_scheme : Type.substitution -> dirty_scheme -> dirty_scheme
-val pos_neg_ty_scheme : ty_scheme -> (Type.ty_param, Type.dirt_param, Type.region_param) Trio.t * (Type.ty_param, Type.dirt_param, Type.region_param) Trio.t
-val pos_neg_dirtyscheme : dirty_scheme -> (Type.ty_param, Type.dirt_param, Type.region_param) Trio.t * (Type.ty_param, Type.dirt_param, Type.region_param) Trio.t
+val beautify_ty_scheme : ty_scheme -> ty_scheme
+val beautify_dirty_scheme : dirty_scheme -> dirty_scheme
+val skeletons_non_poly_scheme : 'a t -> Type.ty_param list list * (Type.ty_param, Type.dirt_param, Type.region_param) Trio.t
 val print_ty_scheme : ty_scheme -> Format.formatter -> unit
 val print_dirty_scheme : dirty_scheme -> Format.formatter -> unit

src/typing/smartPrint.ml

@@ -67,31 +67,14 @@ let rec print ?(non_poly=Trio.empty) ?(show_dirt_param=fun d -> Some (print_dirt
           print ~at_level:6 "%t %s@ %t" (ty ~max_level:4 t1) (Symbols.handler_arrow ()) (ty ~max_level:4 t2)
   in ty t ppf
 
-let context skeletons ctx ppf =
-  match ctx with
-  | [] -> ()
-  | _ -> Print.print ppf "(@[%t@]).@ " (Print.sequence ", " (fun (x, t) ppf -> Print.print ppf "%t : %t" (Untyped.Variable.print x) (print skeletons t)) ctx)
-
-let extend_non_poly (ts, ds, rs) skeletons =
-  let add_skel skel new_ts =
-    if List.exists (fun t -> List.mem t ts) skel then
-    skel @ new_ts else new_ts
-  in
-  let ts = List.fold_right add_skel skeletons ts in
-  (Common.uniq ts, ds, rs)
-
-let show_dirt_param ~non_poly:(_, ds, _) (ctx, ty, cnstrs) =
+let show_dirt_param ~non_poly:(_, ds, _) =
   fun ((Type.Dirt_Param k) as p) -> Some (fun ppf -> (Symbols.dirt_param k (List.mem p ds) ppf))
 
 let print_ty_scheme ty_sch ppf =
-  let sbst = Type.beautifying_subst () in
-  let _, (_, ds, _) = pos_neg_ty_scheme ty_sch in
-  ignore (Common.map sbst.Type.dirt_param ds);
-  let (ctx, ty, cnstrs) = subst_ty_scheme sbst ty_sch in
-  let skeletons = Constraints.skeletons cnstrs in
-  let non_poly = Trio.flatten_map (fun (x, t) -> let pos, neg = Type.pos_neg_params Tctx.get_variances t in pos @@@ neg) ctx in
-  let non_poly = extend_non_poly non_poly skeletons in
-  let show_dirt_param = show_dirt_param (ctx, ty, cnstrs) ~non_poly in
+  let ty_sch = Scheme.beautify_ty_scheme ty_sch in
+  let skeletons, non_poly = Scheme.skeletons_non_poly_scheme ty_sch in
+  let show_dirt_param = show_dirt_param ~non_poly in
+  let (ctx, ty, cnstrs) = ty_sch in
   if !Config.effect_annotations then
     Print.print ppf "%t | %t"
       (print ~show_dirt_param skeletons ty)
@@ -100,14 +83,10 @@ let print_ty_scheme ty_sch ppf =
     print ~non_poly skeletons ty ppf
 
 let print_dirty_scheme drty_sch ppf =
-  let sbst = Type.beautifying_subst () in
-  let _, (_, ds, _) = pos_neg_dirtyscheme drty_sch in
-  ignore (Common.map sbst.Type.dirt_param ds);
-  let (ctx, (ty, drt), cnstrs) = subst_dirty_scheme sbst drty_sch in
-  let skeletons = Constraints.skeletons cnstrs in
-  let non_poly = Trio.flatten_map (fun (x, t) -> let pos, neg = Type.pos_neg_params Tctx.get_variances t in pos @@@ neg) ctx in
-  let non_poly = extend_non_poly non_poly skeletons in
-  let show_dirt_param = show_dirt_param (ctx, (Type.Arrow (Type.unit_ty, (ty, drt))), cnstrs) ~non_poly in
+  let drty_sch = Scheme.beautify_dirty_scheme drty_sch in
+  let skeletons, non_poly = Scheme.skeletons_non_poly_scheme drty_sch in
+  let show_dirt_param = show_dirt_param ~non_poly in
+  let (ctx, (ty, drt), cnstrs) = drty_sch in
   if !Config.effect_annotations then
     if show_dirt show_dirt_param drt then
       Print.print ppf "%t ! %t | %t"