Merge branch 'compile-clause-early' of github.com:LPCIC/elpi into compile-clause-early

# Conflicts:
#	src/bl.ml
#	src/bl.mli
#	src/compiler.ml
#	src/discrimination_tree.ml
#	src/discrimination_tree.mli
#	src/parser/ast.ml
#	src/parser/ast.mli
#	src/runtime.ml

Author: gares

src/API.ml

@@ -1381,6 +1381,7 @@ module Utils = struct
         | Some (`After,x) -> [After x]
         | Some (`Before,x) -> [Before x]
         | Some (`Replace,x) -> [Replace x]
+        | Some (`Remove,x) -> [Remove x]
         | None -> []) in
     [Program.Clause {
       Clause.loc = loc;

src/API.mli

@@ -1243,7 +1243,7 @@ module Utils : sig
 
   (** Hackish, in particular the output should be a compiled program *)
   val clause_of_term :
-    ?name:string -> ?graft:([`After | `Before | `Replace] * string) ->
+    ?name:string -> ?graft:([`After | `Before | `Replace | `Remove] * string) ->
     depth:int -> Ast.Loc.t -> Data.term -> Ast.program
 
   (** Lifting/restriction/beta (LOW LEVEL, don't use) *)

src/bl.ml

@@ -88,11 +88,10 @@ module Array = struct
     in
       shift t (i+len-1)
 
-
-  let shift_left1 t i len =
+  let shift_left t i len =
     let rec shift t j =
-      if i = len-1 then t
-      else shift (set t j (get t (j+1))) (i+1)
+      if j = len-1 then t
+      else shift (set t j (get t (j+1))) (j + 1)
     in
       shift t i
 
@@ -140,14 +139,26 @@ let rec rcons elt l =
   | BArray { len; data } when len < Array.length data -> BArray { len = len + 1; data = Array.set data len elt }
   | BArray { len; data } -> extend len data elt
 
+let rec replace f x = function
+  | BCons (head,tail) when f head -> BCons(x,tail)
+  | BCons (head, tail) -> BCons (head, replace f x tail)
+  | BArray { len; data } as a ->
+      let rec aux i =
+        if i < len then
+          if f data.(i) then BArray { len; data = Array.set data i x }
+          else aux (i+1)
+        else
+          a
+      in
+        aux 0
+
 let rec remove f = function
   | BCons (head,tail) when f head -> tail
   | BCons (head, tail) -> BCons (head, remove f tail)
   | BArray { len; data } as a ->
       let rec aux i =
         if i < len then
-          if f data.(i) then
-            BArray { len = len - 1; data = Array.shift_left1 data i len }
+          if f data.(i) then BArray { len = len-1; data = Array.shift_left data i len }
           else aux (i+1)
         else 
           a

src/bl.mli

@@ -15,6 +15,8 @@ val empty : unit -> 'a t
 val cons : 'a -> 'a t -> 'a t
 val rcons : 'a -> 'a t -> 'a t
 
+val replace : ('a -> bool) -> 'a -> 'a t -> 'a t
+val remove : ('a -> bool) -> 'a t -> 'a t
 val insert : ('a -> int) -> 'a -> 'a t -> 'a t
 val remove : ('a -> bool) -> 'a t -> 'a t
 

src/compiler.ml

@@ -655,6 +655,8 @@ end = struct (* {{{ *)
       error ~loc ("illegal attribute " ^ show_raw_attribute a) in
     let illegal_replace s =
       error ~loc ("replacing clause for "^ s ^" cannot have a name attribute") in
+    let illegal_remove_id s =
+      error ~loc ("remove clause for "^ s ^" cannot have a name attribute") in
     let rec aux_attrs r = function
       | [] -> r
       | Name s :: rest ->
@@ -669,6 +671,9 @@ end = struct (* {{{ *)
       | Replace s :: rest ->
           if r.insertion <> None then duplicate_err "insertion";
           aux_attrs { r with insertion = Some (Replace s) } rest
+      | Remove s :: rest ->
+          if r.insertion <> None then duplicate_err "insertion";
+          aux_attrs { r with insertion = Some (Remove s) } rest
       | If s :: rest ->
          if r.ifexpr <> None then duplicate_err "if";
          aux_attrs { r with ifexpr = Some s } rest
@@ -678,6 +683,7 @@ end = struct (* {{{ *)
     begin
       match attributes.insertion, attributes.id with
       | Some (Replace x), Some _ -> illegal_replace x
+      | Some (Remove x), Some _ -> illegal_remove_id x
       | _ -> ()
     end;
     { c with Clause.attributes }
@@ -694,7 +700,7 @@ end = struct (* {{{ *)
       | If s :: rest ->
          if r.cifexpr <> None then duplicate_err "if";
          aux_chr { r with cifexpr = Some s } rest
-      | (Before _ | After _ | Replace _ | External | Index _) as a :: _ -> illegal_err a 
+      | (Before _ | After _ | Replace _ | Remove _ | External | Index _) as a :: _ -> illegal_err a 
     in
     let cid = Loc.show loc in 
     { c with Chr.attributes = aux_chr { cid; cifexpr = None } attributes }
@@ -725,7 +731,7 @@ end = struct (* {{{ *)
            | Some (Structured.Index _) -> duplicate_err "index"
            | Some _ -> error ~loc "external predicates cannot be indexed"
          end
-      | (Before _ | After _ | Replace _ | Name _ | If _) as a :: _ -> illegal_err a 
+      | (Before _ | After _ | Replace _ | Remove _ | Name _ | If _) as a :: _ -> illegal_err a 
     in
     let attributes = aux_tatt None attributes in
     let attributes =
@@ -2225,7 +2231,7 @@ let rec constants_of acc = function
 let w_symbol_table s f x =
   let table = Symbols.compile_table @@ State.get Symbols.table s in
   let pp_ctx = { table; uv_names = ref (IntMap.empty,0) } in
-  Util.set_spaghetti_printer Data.pp_const (R.Pp.pp_constant ~pp_ctx);
+  Util.set_spaghetti_printer pp_const (R.Pp.pp_constant ~pp_ctx);
   f x
 
 (* Compiler passes *)

src/discrimination_tree.ml

@@ -165,13 +165,22 @@ module Trie = struct
 
   let is_empty x = x == empty
 
-  let rec remove p = function
+  let rec replace p x = function
     | Node { data; other; listTailVariable; map } ->
         Node {
-          data = data |> List.filter (fun y -> not(p y));
-          other = other |> Option.map (remove p);
-          listTailVariable = listTailVariable |> Option.map (remove p);
-          map = map |> Ptmap.map (remove p);
+          data = data |> List.map (fun y -> if p y then x else y);
+          other = other |> Option.map (replace p x);
+          listTailVariable = listTailVariable |> Option.map (replace p x);
+          map = map |> Ptmap.map (replace p x);
+        }
+      
+  let rec remove f = function
+    | Node { data; other; listTailVariable; map } ->
+        Node {
+          data = data |> List.filter (fun x -> not (f x));
+          other = other |> Option.map (remove f);
+          listTailVariable = listTailVariable |> Option.map (remove f);
+          map = map |> Ptmap.map (remove f);
         }
 
   let add (a : Path.t) v t =
@@ -391,7 +400,8 @@ let retrieve cmp_data path { t } =
   let r = call (retrieve ~pos:0 path t) in
   Bl.of_list @@ List.sort cmp_data r
 
-let remove p i = { i with t = Trie.remove p i.t }
+let replace p x i = { i with t = Trie.replace p x i.t }
+let remove keep dt = { dt with t = Trie.remove keep dt.t}
 
 module Internal = struct
   let kConstant = kConstant

src/discrimination_tree.mli

@@ -51,7 +51,8 @@ val empty_dt : 'b list -> 'a t
 *)
 val retrieve : ('a -> 'a -> int) -> Path.t -> 'a t -> 'a Bl.scan
 
-val remove : ('a -> bool) -> 'a t -> 'a t
+val replace : ('a -> bool) -> 'a -> 'a t -> 'a t
+val remove  : ('a -> bool) -> 'a t -> 'a t
 
 (***********************************************************)
 (* Printers                                                *)

src/parser/ast.ml

@@ -143,6 +143,7 @@ type raw_attribute =
   | After of string
   | Before of string
   | Replace of string
+  | Remove of string
   | External
   | Index of int list * string option
 [@@deriving show]
@@ -318,7 +319,7 @@ and attribute = {
   id : string option;
   ifexpr : string option;
 }
-and insertion = Insert of insertion_place | Replace of string
+and insertion = Insert of insertion_place | Replace of string | Remove of string
 and insertion_place = Before of string | After of string
 and tattribute =
   | External

src/parser/ast.mli

@@ -73,6 +73,7 @@ type raw_attribute =
   | After of string
   | Before of string
   | Replace of string
+  | Remove of string
   | External
   | Index of int list * string option
 [@@ deriving show]
@@ -213,7 +214,7 @@ and attribute = {
   id : string option;
   ifexpr : string option;
 }
-and insertion = Insert of insertion_place | Replace of string
+and insertion = Insert of insertion_place | Replace of string | Remove of string
 and insertion_place = Before of string | After of string
 and cattribute = {
   cid : string;

src/parser/grammar.mly

@@ -300,6 +300,7 @@ attribute:
 | AFTER; s = STRING { After s }
 | BEFORE; s = STRING { Before s }
 | REPLACE; s = STRING { Replace s }
+| REMOVE; s = STRING { Remove s }
 | EXTERNAL { External }
 | INDEX; LPAREN; l = nonempty_list(indexing) ; RPAREN; o = option(STRING) { Index (l,o) }
 
@@ -400,6 +401,7 @@ constant:
 | BEFORE { Func.from_string "before" }
 | AFTER { Func.from_string "after" }
 | REPLACE { Func.from_string "replace" }
+| REMOVE { Func.from_string "remove" }
 | INDEX { Func.from_string "index" }
 | c = IO { Func.from_string @@ String.make 1 c }
 | CUT { Func.cutf }