Push anchor metadata through path p/c

Path contexts now contain the most recent computed anchor as metadata,
and checks on anchor safety now occur at generation site.  The
path generation samples show that the anchor passes neatly through into
the metadata attached to the generated paths.

This makes it easier to do #220; we still currently generate then
reject paths that make no sense for anchor blocks, but it should be
much easier to add the special-casing now (if we can exfiltrate the
anchor from the path filter).

lib/fuzz/src/path.ml

@@ -248,6 +248,9 @@ module Stms = struct
     | On_range (_, l) ->
         l
 
+  (* TODO(@MattWindsor91): solve pos/index inconsistency*)
+  let span (p : t) : Utils.My_list.Span.t = {pos= p.@(index); len= len p}
+
   let is_nested : t -> bool = function
     | In_stm (_, In_if _) | In_stm (_, In_flow _) ->
         true

lib/fuzz/src/path.mli

@@ -122,6 +122,9 @@ module Stms : sig
   val index : ('i, index, t, [< field]) Accessor.Simple.t
   (** [index] focuses on the index of a statement-list path fragment. *)
 
+  val span : t -> Utils.My_list.Span.t
+  (** [span p] gets the span of statements accessed by [p]. *)
+
   val len : t -> int
   (** [len p] gets the number of statements accessed by [p]. *)
 
@@ -141,6 +144,8 @@ module Stms : sig
   val stm : index -> t
   (** [stm index] is shorthand for [in_stm index Stm.this_stm]. *)
 
+  (* TODO(@MattWindsor91): spans *)
+
   val on_range : index -> length -> t
   (** [on_range index length] focuses on an [length]-wide slice of a
       statement list starting at [index]. [length] may be 0, in which case

lib/fuzz/src/path_consumers.ml

@@ -51,14 +51,7 @@ let checked_transform (stm : Subject.Statement.t) ~(ctx : ctx)
   Or_error.tag ~tag
     Or_error.(
       Let_syntax.(
-        let%bind () =
-          tag (Path_context.check_filter_req ctx) ~tag:"while checking flags"
-        in
-        let%bind () =
-          tag
-            (Path_context.check_filter_stm ctx ~stm)
-            ~tag:"while checking statements"
-        in
+        let%bind () = Path_context.check_end ctx ~stms:[stm] in
         f stm))
 
 open Helpers
@@ -76,6 +69,10 @@ module Block = struct
             (Path_context.check_filter_req ctx)
             ~tag:"checking flags on insertion"
           >>= fun () ->
+          tag
+            (Path_context.check_anchor ctx)
+            ~tag:"checking anchor on insertion"
+          >>= fun () ->
           Utils.My_list.splice b ~span:{pos; len= 0}
             ~replace_f:(Fn.const stms))
     | x ->
@@ -88,16 +85,7 @@ module Block = struct
     Or_error.(
       tag ~tag:"in on-range transform-list"
         Let_syntax.(
-          let%bind () =
-            tag
-              (Path_context.check_filter_req ctx)
-              ~tag:"while checking flags"
-          in
-          let%bind () =
-            tag
-              (Path_context.check_filter_stms ctx ~stms)
-              ~tag:"while checking statements"
-          in
+          let%bind () = Path_context.check_end ctx ~stms in
           f stms))
 
   let on_range (b : Subject.Statement.t list) ~(span : Utils.My_list.Span.t)
@@ -119,17 +107,15 @@ module Block = struct
 
   let consume_stms (b : Subject.Statement.t list) ~(path : Path.Stms.t)
       ~(mu : mu) ~(ctx : ctx) : Subject.Statement.t list Or_error.t =
-    Or_error.Let_syntax.(
-      let%bind () =
-        Path_context.check_anchor ctx ~block_len:(List.length b) ~path
-      in
-      match path with
-      | Insert pos ->
-          insert b ~pos ~ctx
-      | On_range (pos, len) ->
-          on_range b ~span:{pos; len} ~ctx
-      | In_stm (pos, path) ->
-          in_stm b ~pos ~path ~mu ~ctx)
+    let ctx = ctx.@(Path_context.block_len) <- List.length b in
+    let ctx = Path_context.update_anchor ctx ~span:(Path.Stms.span path) in
+    match path with
+    | Insert pos ->
+        insert b ~pos ~ctx
+    | On_range (pos, len) ->
+        on_range b ~span:{pos; len} ~ctx
+    | In_stm (pos, path) ->
+        in_stm b ~pos ~path ~mu ~ctx
 
   let consume (b : Subject.Block.t) ~(path : Path.Stms.t) ~(mu : mu) :
       ctx:ctx -> Subject.Block.t Or_error.t =
@@ -187,7 +173,7 @@ struct
             this_cond x ~ctx
         | In_block rest ->
             let ctx =
-              Path_context.set_block_kind ctx (F.block_kind rest x)
+              ctx.@(Path_context.block_kind) <- F.block_kind rest x
             in
             in_block x ~rest ~mu ~ctx)
 end

lib/fuzz/src/path_context.ml

@@ -14,13 +14,18 @@ open Import
 
 type 'k t =
   { kind: 'k
-  ; last_block: Path_filter.Block.t
+  ; block_kind: Path_filter.Block.t
+  ; block_len: int
   ; meta: Path_meta.t
   ; filter: Path_filter.t }
-[@@deriving fields]
+[@@deriving accessors]
 
 let init ?(filter : Path_filter.t = Path_filter.zero) (kind : 'k) : 'k t =
-  {kind; last_block= Top; meta= Path_meta.zero; filter}
+  {kind; block_kind= Top; block_len= 0; meta= Path_meta.zero; filter}
+
+let update_anchor (x : 'k t) ~(span : Utils.My_list.Span.t) : 'k t =
+  let anchor = Path_meta.Anchor.of_dimensions ~span ~block_len:x.block_len in
+  x.@(meta @> Path_meta.anchor) <- anchor
 
 let add_flags (x : 'k t) (flags : Set.M(Path_meta.Flag).t) : 'k t Or_error.t
     =
@@ -30,17 +35,13 @@ let add_flags (x : 'k t) (flags : Set.M(Path_meta.Flag).t) : 'k t Or_error.t
     let%map () = Path_filter.check_not x.filter ~meta in
     {x with meta})
 
-let set_block_kind (x : 'k t) (kind : Path_filter.Block.t) : 'k t =
-  {x with last_block= kind}
-
-let check_anchor (x : 'k t) ~(path : Path.Stms.t) ~(block_len : int) :
-    unit Or_error.t =
-  Path_filter.check_anchor x.filter ~path ~block_len
+let check_anchor (x : 'k t) : unit Or_error.t =
+  Path_filter.check_anchor x.filter ?anchor:x.meta.anchor
 
 let check_filter_req (x : 'k t) : unit Or_error.t =
   Or_error.all_unit
     [ Path_filter.check_req x.filter ~meta:x.meta
-    ; Path_filter.check_block x.filter ~block:x.last_block ]
+    ; Path_filter.check_block x.filter ~block:x.block_kind ]
 
 let check_filter_stm (x : 'k t) ~(stm : Subject.Statement.t) :
     unit Or_error.t =
@@ -50,9 +51,19 @@ let check_filter_stms (x : 'k t) ~(stms : Subject.Statement.t list) :
     unit Or_error.t =
   Tx.Or_error.combine_map_unit stms ~f:(fun stm -> check_filter_stm x ~stm)
 
+let check_end (x : 'k t) ~(stms : Subject.Statement.t list) : unit Or_error.t
+    =
+  Or_error.(
+    all_unit
+      [ tag (check_filter_req x) ~tag:"while checking flags"
+      ; tag (check_filter_stms x ~stms) ~tag:"while checking statements"
+      ; tag (check_anchor x) ~tag:"while checking anchor" ])
+
 let check_thread_ok (x : _ t) ~(thread : int) : unit Or_error.t =
-  (* TODO(@MattWindsor91): push error into Path_filter? *)
   Path_filter.check_thread_ok x.filter ~thread
 
 let lift_path (x : 'k t) ~(path : 'p) : 'p Path_meta.With_meta.t =
   Path_meta.With_meta.make path ~meta:x.meta
+
+(* TODO(@MattWindsor91): do something about this overload? *)
+let kind (k : 'a t) : 'a = k.kind

lib/fuzz/src/path_context.mli

@@ -17,6 +17,7 @@
     the shared context type used by both types of path operation. *)
 
 open Base
+open Import
 
 (** Type of context, predicated on the kind information [k]. *)
 type 'k t
@@ -30,9 +31,15 @@ val init : ?filter:Path_filter.t -> 'k -> 'k t
 val add_flags : 'k t -> Set.M(Path_meta.Flag).t -> 'k t Or_error.t
 (** [add_flags ctx flags] registers [flags] in [ctx]. *)
 
-val set_block_kind : 'k t -> Path_filter.Block.t -> 'k t
-(** [set_block_kind ctx kind] registers the inmost block kind in [ctx] as
-    being [ctx]. *)
+val block_kind : ('i, Path_filter.Block.t, 'k t, [< field]) Accessor.Simple.t
+(** [block_kind] is an accessor for the inmost block kind in [ctx]. *)
+
+val block_len : ('i, int, 'k t, [< field]) Accessor.Simple.t
+(** [block_len] is an accessor for the inmost block length in [ctx]. *)
+
+val update_anchor : 'k t -> span:Utils.My_list.Span.t -> 'k t
+(** [update_anchor ctx] uses [span] and the last entered block length to
+    deduce an anchor, and updates [ctx]'s metadata accordingly. *)
 
 (** {1 Using context data} *)
 
@@ -45,8 +52,8 @@ val lift_path : _ t -> path:'p -> 'p Path_meta.With_meta.t
 (** {2 Checking the path filter} *)
 
 val check_filter_req : _ t -> unit Or_error.t
-(** [check_filter_req ctx] checks [ctx]'s filter's positive requirements
-    against the context state. *)
+(** [check_filter_req ctx] checks [ctx]'s filter's positive metadata and
+    block-type requirements against the context state. *)
 
 val check_filter_stm : _ t -> stm:Subject.Statement.t -> unit Or_error.t
 (** [check_filter_stm ctx ~stm] performs [ctx]'s statement end-checks on
@@ -61,7 +68,11 @@ val check_thread_ok : _ t -> thread:int -> unit Or_error.t
 (** [check_thread_ok ctx] checks that [ctx]'s filter allows entering thread
     [thread]. *)
 
-val check_anchor :
-  _ t -> path:Path.Stms.t -> block_len:int -> unit Or_error.t
-(** [check_anchor ctx] checks [ctx]'s filter to see whether [path] meets the
-    anchoring requirements within a block of length [block_len]. *)
+val check_anchor : _ t -> unit Or_error.t
+(** [check_anchor ctx] checks [ctx]'s filter to see whether [span] (usually
+    [Path.Stms.span path]) meets the anchoring requirements. *)
+
+val check_end : _ t -> stms:Subject.Statement.t list -> unit Or_error.t
+(** [check_end ctx ~stms] runs {!check_filter_req}, {!check_filter_stms}, and
+    {!check_anchor} simultaneously. It should be used for consuming paths,
+    and producing statement-based paths; statement-list paths *)

lib/fuzz/src/path_filter.ml

@@ -124,34 +124,6 @@ let ( + ) (l : t) (r : t) : t =
 let add_if (x : t) ~(when_ : bool) ~(add : t) : t =
   if when_ then x + add else x
 
-module Anchor_check = struct
-  type t = {is_nested: bool; span: Utils.My_list.Span.t; block_len: int}
-  [@@deriving sexp]
-
-  let of_path (path : Path.Stms.t) ~(block_len : int) : t =
-    Path.Stms.
-      { span= {pos= path.@(index); len= len path}
-      ; is_nested= is_nested path
-      ; block_len }
-end
-
-let is_anchored (anc : Path_meta.Anchor.t) ~(check : Anchor_check.t) : bool =
-  check.is_nested
-  || Path_meta.Anchor.(
-       incl_opt ~includes:anc
-         (of_dimensions ~span:check.span ~block_len:check.block_len))
-
-let check_anchor (anc : Path_meta.Anchor.t) ~(path : Path.Stms.t)
-    ~(block_len : int) : unit Or_error.t =
-  let check = Anchor_check.of_path path ~block_len in
-  Tx.Or_error.unless_m (is_anchored anc ~check) ~f:(fun () ->
-      Or_error.error_s
-        [%message
-          "Path is not anchored properly"
-            ~anchor:(anc : Path_meta.Anchor.t)
-            ~path_fragment:(path : Path.Stms.t)
-            ~check:(check : Anchor_check.t)])
-
 let ends_in_block (blk : Block.t) : t = {zero with block= Some (Valid blk)}
 
 let require_meta (meta : Path_meta.t) : t = {zero with req_meta= meta}
@@ -241,10 +213,16 @@ let check_not (filter : t) ~(meta : Path_meta.t) : unit Or_error.t =
   error_of_flags ~polarity:"forbidden"
     (Set.inter filter.not_flags meta.flags)
 
-let check_anchor (filter : t) ~(path : Path.Stms.t) ~(block_len : int) :
+let check_anchor ?(anchor : Path_meta.Anchor.t option) (filter : t) :
     unit Or_error.t =
-  Tx.Option.With_errors.iter_m filter.req_meta.anchor
-    ~f:(check_anchor ~path ~block_len)
+  let includes = filter.req_meta.anchor in
+  Tx.Or_error.unless_m (Path_meta.Anchor.incl_opt anchor ?includes)
+    ~f:(fun () ->
+      Or_error.error_s
+        [%message
+          "Path doesn't anchor to block as required by filter"
+            ~got:(anchor : Path_meta.Anchor.t option)
+            ~want:(includes : Path_meta.Anchor.t option)])
 
 let check_block (filter : t) ~(block : Block.t) : unit Or_error.t =
   Tx.Option.With_errors.iter_m filter.block ~f:(Block.check ~block)

lib/fuzz/src/path_filter.mli

@@ -77,7 +77,10 @@ val live_loop_surround : t
 (** [live_loop_surround] contains the restrictions that should apply on any
     attempt to surround statements with a live-code loop. *)
 
-(** {2 End checks} *)
+(** {2 End checks}
+
+    These don't apply to the statements we are adding with insertion paths;
+    only the statements reached by transforms and transform-lists. *)
 module End_check : sig
   (** Type of end checks. *)
   type t =
@@ -149,7 +152,10 @@ val check_final_statement : t -> stm:Subject.Statement.t -> unit Or_error.t
     a [This_stm] reference to [stm], and checks whether such a final
     statement destination is ok according to the predicates in [filter]. *)
 
-val check_anchor : t -> path:Path.Stms.t -> block_len:int -> unit Or_error.t
+val check_anchor : ?anchor:Path_meta.Anchor.t -> t -> unit Or_error.t
+(** [check_anchor ?anchor filter] checks whether the anchor represented by
+    [anchor], if any, satisfies the anchor requirement in [filter]. *)
+
 (** [check_anchor filter ~path ~block_len] should be applied before
     constructing any path targeting a member of a block of length
     [block_len], and checks whether [path] is properly anchored within it. *)

lib/fuzz/src/path_meta.ml

@@ -60,6 +60,14 @@ module Anchor = struct
   (* nb: the compare instance here is NOT inclusion. *)
   type t = Top | Bottom | Full [@@deriving sexp, compare, equal]
 
+  let pp (f : Formatter.t) : t -> unit = function
+    | Top ->
+        Fmt.(styled (`Fg `Red) (any "T") f ())
+    | Full ->
+        Fmt.(styled (`Fg `Magenta) (any "F") f ())
+    | Bottom ->
+        Fmt.(styled (`Fg `Blue) (any "B") f ())
+
   let merge (l : t) (r : t) : t =
     match (l, r) with
     | Top, Top ->
@@ -155,7 +163,10 @@ module Meta = struct
             ~flags:(m.flags : Set.M(Flag).t)
             ~contradictions:(contra : Set.M(Flag).t list)]
 
-  let pp : t Fmt.t = (* for now *) Fmt.using (fun x -> x.flags) pp_flag_set
+  let pp : t Fmt.t =
+    Fmt.(
+      using (fun x -> x.flags) pp_flag_set
+      ++ using (fun x -> x.anchor) (option (brackets Anchor.pp)))
 end
 
 include Meta