Remove errors in LSC

Author: engboris

src/expr.ml

@@ -165,10 +165,10 @@ let rec sgen_expr_of_expr (e : expr) : sgen_expr =
     Clean (sgen_expr_of_expr g)
   (* exec *)
   | List [ Symbol k; g ] when equal_string k "exec" ->
-    Exec (sgen_expr_of_expr g)
+    Exec (false, sgen_expr_of_expr g)
   (* linear exec *)
   | List [ Symbol k; g ] when equal_string k "linexec" ->
-    LinExec (sgen_expr_of_expr g)
+    Exec (true, sgen_expr_of_expr g)
   (* linear exec *)
   | List [ Symbol k; g ] when equal_string k "eval" ->
     Eval (sgen_expr_of_expr g)

src/lsc_ast.ml

@@ -2,7 +2,6 @@ open Base
 open Pretty
 open Out_channel
 open In_channel
-open Lsc_err
 
 let ( let* ) x f = Result.bind x ~f
 
@@ -339,21 +338,6 @@ let fusion repl1 repl2 s1 s2 bans1 bans2 theta : star =
   ; bans = List.map (nbans1 @ nbans2) ~f:(fmap_ban ~f:(subst theta))
   }
 
-let apply_effect r theta : (unit, err_effect) Result.t =
-  match (r, theta) with
-  | Func ((Noisy, (_, "print")), _), [] -> Error (TooFewArgs "print")
-  | Func ((Noisy, (_, "print")), _), _ :: _ :: _ -> Error (TooManyArgs "print")
-  | Func ((Noisy, (_, "print")), _), [ (_, Func ((_, (Null, arg)), [])) ] ->
-    String.strip ~drop:(fun x -> equal_char x '\"') arg |> output_string stdout;
-    flush stdout;
-    Ok ()
-  | Func ((Noisy, (_, "print")), _), [ (_, arg) ] ->
-    output_string stdout (string_of_ray arg);
-    flush stdout;
-    Ok ()
-  | Func ((Noisy, (_, s)), _), _ -> Error (UnknownEffect s)
-  | _ -> Ok ()
-
 let pause () =
   flush stdout;
   let _ = input_line stdin in
@@ -384,9 +368,9 @@ let coherent_bans bans =
 (* interaction between one selected ray and one selected action *)
 let rec interaction ~showtrace ~queue repl1 repl2
   (selected_action, other_actions) (selected_ray, other_rays, bans) :
-  (star list, err_effect) Result.t =
+  star list =
   match selected_action.content with
-  | [] -> Ok []
+  | [] -> []
   | r' :: s' when not (is_polarised r') ->
     interaction ~showtrace ~queue:(r' :: queue) repl1 repl2
       ({ content = s'; bans }, other_actions)
@@ -405,15 +389,14 @@ let rec interaction ~showtrace ~queue repl1 repl2
         (selected_ray, other_rays, bans)
     (* if there is an actual connection between rays *)
     | Some theta ->
-      let* _ = apply_effect selected_ray theta in
       begin
         if showtrace then
           output_string stdout
           @@ Printf.sprintf "success with %s." (string_of_subst theta);
         if showtrace then pause ()
       end;
       (* action is consumed when execution is linear *)
-      let* next =
+      let next =
         interaction ~showtrace ~queue:(r' :: queue) repl1 repl2
           ({ content = s'; bans }, other_actions)
           (selected_ray, other_rays, bans)
@@ -423,29 +406,29 @@ let rec interaction ~showtrace ~queue repl1 repl2
         fusion repl1 repl2 other_rays other_rays' bans selected_action.bans
           theta
       in
-      let* res =
+      let res =
         if coherent_bans after_fusion.bans then begin
           let _ =
             if showtrace then
               output_string stdout
               @@ Printf.sprintf "  add star %s." (string_of_star after_fusion)
           in
-          Ok (after_fusion :: next)
+          after_fusion :: next
         end
         else begin
           if showtrace then
             output_string stdout
             @@ Printf.sprintf "  result filtered out by constraint.";
-          Ok next
+          next
         end
       in
       if showtrace then pause ();
       ident_counter := !ident_counter + 2;
-      Ok res )
+      res )
 
 (* search partner for a selected ray within a set of available actions *)
 let search_partners ~linear ~showtrace (selected_ray, other_rays, bans) actions
-  : (star list * star list, err_effect) Result.t =
+  : star list * star list =
   if showtrace then begin
     let str_ray = string_of_ray selected_ray in
     let str_rays = string_of_raylist other_rays in
@@ -455,29 +438,29 @@ let search_partners ~linear ~showtrace (selected_ray, other_rays, bans) actions
   end;
   let repl1 = replace_indices !ident_counter in
   let rec try_actions acc = function
-    | [] -> Ok ([], acc)
+    | [] -> ([], acc)
     | selected_action :: other_actions ->
       let repl2 = replace_indices (!ident_counter + 1) in
-      let* res =
+      let res =
         interaction ~showtrace ~queue:[] repl1 repl2
           (selected_action, other_actions)
           (selected_ray, other_rays, bans)
       in
       if (not @@ List.is_empty res) && linear then
-        let* next, new_actions = try_actions acc other_actions in
-        Ok (res @ next, new_actions)
+        let next, new_actions = try_actions acc other_actions in
+        (res @ next, new_actions)
       else
-        let* next, new_actions =
+        let next, new_actions =
           try_actions (selected_action :: acc) other_actions
         in
-        Ok (res @ next, new_actions)
+        (res @ next, new_actions)
   in
   try_actions [] actions
 
 let rec select_ray ~linear ~showtrace ~queue actions other_states
-  (selected_state, bans) : (star list option * star list, err_effect) Result.t =
+  (selected_state, bans) : star list option * star list =
   match selected_state with
-  | [] -> Ok (None, actions)
+  | [] -> (None, actions)
   (* if unpolarized, no need to try, try other stars *)
   | r :: rs when not (is_polarised r) ->
     select_ray ~linear ~showtrace ~queue:(r :: queue) actions other_states
@@ -490,48 +473,45 @@ let rec select_ray ~linear ~showtrace ~queue actions other_states
         actions
     with
     (* interaction did nothing (no partner), try other rays *)
-    | Ok ([], new_actions) ->
+    | ([], new_actions) ->
       select_ray ~linear ~showtrace ~queue:(selected_ray :: queue) new_actions
         other_states (other_rays, bans)
     (* interaction returns a result, keep it for the next round *)
-    | Ok (new_stars, new_actions) -> Ok (Some new_stars, new_actions)
-    | Error e -> Error e )
+    | (new_stars, new_actions) -> (Some new_stars, new_actions))
 
 let rec select_star ~linear ~showtrace ~queue actions :
-  star list -> (star list option * star list, err_effect) Result.t = function
-  | [] -> Ok (None, actions)
+  star list -> star list option * star list = function
+  | [] -> (None, actions)
   (* select a state star and try finding a partner for each ray *)
   | selected_state :: other_states -> (
     match
       select_ray ~linear ~showtrace ~queue:[] actions other_states
         (selected_state.content, selected_state.bans)
     with
     (* no success with this star, try other stars *)
-    | Ok (None, new_actions) ->
+    | (None, new_actions) ->
       select_star ~linear ~showtrace new_actions
         ~queue:(selected_state :: queue) other_states
     (* got new stars to add, construct the result for the next round *)
-    | Ok (Some new_stars, new_actions) ->
-      Ok (Some (List.rev queue @ other_states @ new_stars), new_actions)
-    | Error e -> Error e )
+    | (Some new_stars, new_actions) ->
+      (Some (List.rev queue @ other_states @ new_stars), new_actions))
 
 let string_of_cfg (actions, states) : string =
   Printf.sprintf ">> actions: %s\n>> states: %s\n"
     (string_of_constellation actions)
     (string_of_constellation states)
 
 let exec ?(showtrace = false) ?(linear = false) mcs :
-  (constellation, err_effect) Result.t =
+  constellation =
   (* do a sequence of rounds with a single interaction on state per round *)
   let rec loop ((actions, states) as cfg) =
     if showtrace then begin
       output_string stdout @@ string_of_cfg cfg;
       pause ()
     end;
     match select_star ~linear ~showtrace ~queue:[] actions states with
-    | Ok (None, _) -> Ok states (* no more possible interaction *)
-    | Ok (Some res, new_actions) -> loop (new_actions, res)
-    | Error e -> Error e
+    | (None, _) -> states (* no more possible interaction *)
+    | (Some res, new_actions) -> loop (new_actions, res)
   in
   let cfg = extract_intspace mcs in
   if showtrace then

src/lsc_err.ml

@@ -2,10 +2,8 @@ open Base
 open Lsc_ast
 
 type err =
-  | IllFormedChecker
   | ReservedWord of string
   | UnknownID of string
-  | LscError of Lsc_err.err_effect
 
 type ident = StellarRays.term
 
@@ -18,8 +16,7 @@ type ray_prefix = StellarRays.fmark * idfunc
 and sgen_expr =
   | Raw of marked_constellation
   | Id of ident
-  | Exec of sgen_expr
-  | LinExec of sgen_expr
+  | Exec of bool * sgen_expr
   | Union of sgen_expr list
   | Subst of sgen_expr * substitution
   | Focus of sgen_expr

src/sgen_ast.ml

@@ -1,6 +1,5 @@
 open Base
 open Lsc_ast
-open Lsc_err
 open Sgen_ast
 open Out_channel
 
@@ -22,18 +21,15 @@ let rec map_sgen_expr env ~f : sgen_expr -> (sgen_expr, err) Result.t = function
     | None -> Error (UnknownID (string_of_ray x))
     | Some g -> map_sgen_expr env ~f g
   end
-  | Exec e ->
+  | Exec (b, e) ->
     let* map_e = map_sgen_expr env ~f e in
-    Exec map_e |> Result.return
+    Exec (b, map_e) |> Result.return
   | Kill e ->
     let* map_e = map_sgen_expr env ~f e in
     Kill map_e |> Result.return
   | Clean e ->
     let* map_e = map_sgen_expr env ~f e in
     Clean map_e |> Result.return
-  | LinExec e ->
-    let* map_e = map_sgen_expr env ~f e in
-    LinExec map_e |> Result.return
   | Union es ->
     let* map_es = List.map ~f:(map_sgen_expr env ~f) es |> Result.all in
     Union map_es |> Result.return
@@ -68,18 +64,15 @@ let rec replace_id env (_from : ident) (_to : sgen_expr) e :
   match e with
   | Id x when is_reserved x -> Ok (Id x)
   | Id x when equal_ray x _from -> Ok _to
-  | Exec e ->
+  | Exec (b, e) ->
     let* g = replace_id env _from _to e in
-    Exec g |> Result.return
+    Exec (b, g) |> Result.return
   | Kill e ->
     let* g = replace_id env _from _to e in
     Kill g |> Result.return
   | Clean e ->
     let* g = replace_id env _from _to e in
     Clean g |> Result.return
-  | LinExec e ->
-    let* g = replace_id env _from _to e in
-    LinExec g |> Result.return
   | Union es ->
     let* gs = List.map ~f:(replace_id env _from _to) es |> Result.all in
     Union gs |> Result.return
@@ -104,16 +97,15 @@ let subst_funcs env _from _to =
   map_sgen_expr env ~f:(subst_all_funcs [ (_from, _to) ])
 
 let rec pp_err e : (string, err) Result.t =
+  let red text = "\x1b[31m" ^ text ^ "\x1b[0m" in
   match e with
-  | IllFormedChecker -> "Ill-formed checker.\n" |> Result.return
   | ReservedWord x ->
     Printf.sprintf "%s: identifier '%s' is reserved.\n"
       (red "ReservedWord Error") x
     |> Result.return
   | UnknownID x ->
     Printf.sprintf "%s: identifier '%s' not found.\n" (red "UnknownID Error") x
     |> Result.return
-  | LscError e -> pp_err_effect e |> Result.return
 
 and eval_sgen_expr ~notyping (env : env) :
   sgen_expr -> (marked_constellation, err) Result.t = function
@@ -131,20 +123,9 @@ and eval_sgen_expr ~notyping (env : env) :
     in
     let* mcs = Ok eval_es in
     Ok (List.concat mcs)
-  | Exec e ->
-    let* eval_e = eval_sgen_expr ~notyping env e in
-    begin
-      match exec ~linear:false ~showtrace:false eval_e with
-      | Ok res -> Ok (unmark_all res)
-      | Error e -> Error (LscError e)
-    end
-  | LinExec e ->
+  | Exec (b, e) ->
     let* eval_e = eval_sgen_expr ~notyping env e in
-    begin
-      match exec ~linear:true ~showtrace:false eval_e with
-      | Ok mcs -> Ok (unmark_all mcs)
-      | Error e -> Error (LscError e)
-    end
+    Ok (exec ~linear:b ~showtrace:false eval_e |> unmark_all)
   | Focus e ->
     let* eval_e = eval_sgen_expr ~notyping env e in
     eval_e |> remove_mark_all |> focus |> Result.return
@@ -168,7 +149,7 @@ and eval_sgen_expr ~notyping (env : env) :
           acc |> remove_mark_all |> clean |> focus |> Result.return
         | _ ->
           let origin = acc |> remove_mark_all |> focus in
-          eval_sgen_expr ~notyping env (Focus (Exec (Union [ x; Raw origin ]))) )
+          eval_sgen_expr ~notyping env (Focus (Exec (false, Union [ x; Raw origin ]))) )
     in
     res |> Result.return
   | Subst (e, Extend pf) ->
@@ -244,14 +225,11 @@ let rec eval_decl ~typecheckonly ~notyping env :
   | Trace _ when typecheckonly -> Ok env
   | Trace e ->
     let* eval_e = eval_sgen_expr ~notyping env e in
-    begin
-      match exec ~showtrace:true eval_e with
-      | Ok _ -> Ok env
-      | Error e -> Error (LscError e)
-    end
+    let _ = exec ~showtrace:true eval_e in
+    Ok env
   | Run _ when typecheckonly -> Ok env
   | Run e ->
-    let _ = eval_sgen_expr ~notyping env (Exec e) in
+    let _ = eval_sgen_expr ~notyping env (Exec (false, e)) in
     Ok env
   | Expect (_x, _mcs) -> Ok { objs = []; types = [] } (* TODO *)
   | Use path ->