-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathgopcaml_state.ml
1213 lines (1082 loc) · 50.7 KB
/
gopcaml_state.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
open Core
open Ecaml
open Generic_types
let position_sub1 pos = if Position.to_int pos <= 1 then pos else Position.sub pos 1
let byte_of_position_safe pos = if Int.(pos = 0) then Position.of_int_exn pos else Position.of_byte_position pos
let message ?at msg = Logging.message ?at msg
module State = struct
module Filetype = struct
(** records whether the current file is an interface or implementation *)
type s = Interface | Implementation [@@deriving sexp]
module Enum : Enum.S with type t = s = struct
type t = s
let all = [Interface; Implementation]
let sexp_of_t = sexp_of_s
end
let ty =
let to_ecaml file_type =
match file_type with
| Interface -> Value.intern "interface"
| Implementation -> Value.intern "implementation" in
Value.Type.enum
(Sexp.Atom "filetype")
(module Enum)
to_ecaml
let to_string = function
| Interface -> "interface"
| Implementation -> "implementation"
type t = s
end
module Direction = struct
(** records whether moving forward or backwards *)
type s = Forward | Backward [@@deriving sexp]
module Enum : Enum.S with type t = s = struct
type t = s
let all = [Forward; Backward]
let sexp_of_t = sexp_of_s
end
let ty =
let to_ecaml direction =
match direction with
| Forward -> Value.intern "forward"
| Backward -> Value.intern "backward" in
Value.Type.enum
(Sexp.Atom "direction")
(module Enum)
to_ecaml
let to_string = function
| Forward -> "forward"
| Backward -> "backward"
type t = s
end
module Zipper = struct
type t = Ast_zipper.location
(** elisp type for state of system *)
let ty : t Value.Type.t =
Caml_embed.create_type
(Type_equal.Id.create
~name:"gopcaml-zipper-location"
Sexplib0.Sexp_conv.sexp_of_opaque)
end
(** region of the buffer *)
type region = {
start_mark: Marker.t;
end_mark: Marker.t ;
(** denotes the start and end of the region *)
logical_start: Line_and_column.t;
logical_end: Line_and_column.t
}
(** holds the parse tree for the current file *)
type 'a ast_tree =
(** the variant simply defines the type of ast.
the value is a list of the top-level items, where each item is
reported as: region * ast in that region
when a change occurs, we:
- find region containing change,
- reparse region, update element
- if that fails (could be that toplevel structure changed),
then parse from region start to end of file,
update rest of list
*)
| Impl : (region * Parsetree.structure_item) list -> Parsetree.structure_item ast_tree
| Intf : (region * Parsetree.signature_item) list -> Parsetree.signature_item ast_tree
type parse_tree =
| MkParseTree : 'a ast_tree -> parse_tree
type 'a ast_item =
| ImplIt : (region * Parsetree.structure_item) -> Parsetree.structure_item ast_item
| IntfIt : (region * Parsetree.signature_item) -> Parsetree.signature_item ast_item
type parse_item =
| MkParseItem : 'a ast_item -> parse_item
module TreeBuilder = struct
let unwrap_current_buffer current_buffer =
match current_buffer with Some v -> v | None -> Current_buffer.get ()
(** builds the abstract tree for the current buffer buffer *)
let build_abstract_tree f g h ?current_buffer value =
let current_buffer = unwrap_current_buffer current_buffer in
let lexbuf = Lexing.from_string ~with_positions:true value in
let items =
f lexbuf
|> List.map ~f:(fun item ->
let (iterator,get_result) = Ast_transformer.bounds_iterator () in
g iterator item;
let (min_column, max_column) = get_result () in
let start_marker,end_marker = Marker.create (), Marker.create () in
let get_position column = byte_of_position_safe column in
(* Point.goto_line_and_column Line_and_column.{line;column};
* Point.get () in *)
Marker.set start_marker current_buffer (get_position min_column);
Marker.set end_marker current_buffer (get_position max_column);
{start_mark=start_marker;
end_mark=end_marker;
logical_start = Line_and_column.{line=0;column=min_column};
logical_end = Line_and_column.{line=0;column=max_column};
},item)
in
if not @@ String.is_empty value then
try Either.First (h items) with
Syntaxerr.Error e -> Either.Second e
else Either.First (h [])
let build_implementation_tree =
build_abstract_tree
Generic_parser.implementation
(fun iterator item -> iterator.structure_item iterator item)
(fun x -> Impl x)
let build_interface_tree =
build_abstract_tree
Generic_parser.interface
(fun iterator item -> iterator.signature_item iterator item)
(fun x -> Intf x)
(** determines the file-type of the current file based on its extension *)
let retrieve_current_file_type ~implementation_extensions ~interface_extensions =
Current_buffer.file_name ()
|> Option.bind ~f:(fun file_name ->
String.split ~on:'.' file_name
|> List.last
|> Option.bind ~f:(fun ext ->
if List.mem ~equal:String.(=) implementation_extensions ext
then begin
message ~at:`verbose "filetype is implementation";
Some Filetype.Implementation
end
else if List.mem ~equal:String.(=) interface_extensions ext
then begin
message ~at:`verbose "filetype is interface";
Some Filetype.Interface
end
else None
)
)
(** attempts to parse the current buffer according to the inferred file type *)
let parse_current_buffer ?start ?end_ file_type =
(* retrieve the text for the entire buffer *)
let buffer_text =
Current_buffer.contents ?start ?end_ () |> Text.to_utf8_bytes |> Preprocessing.preprocess in
let perform_parse () =
message ~at:`info "Building parse tree - may take a while if the file is large...";
let start_time = Time_float.now () in
let parse_tree =
let map ~f = Either.map ~second:(fun x -> x) ~first:(fun x -> f x) in
let open Filetype in
match file_type with
| Implementation -> map ~f:(fun x -> MkParseTree x) @@
build_implementation_tree buffer_text
| Interface -> map ~f:(fun x -> MkParseTree x) @@
build_interface_tree buffer_text
in
match parse_tree with
| Either.Second _e ->
message ~at:`info ("Could not build parse tree (syntax error)");
None
| Either.First tree ->
let end_time = Time_float.now () in
message ~at:`info (Printf.sprintf
"Successfully built parse tree (%f ms)"
((Time_float.diff end_time start_time) |> Time_float.Span.to_ms)
);
Some tree
in
if not @@ String.is_empty buffer_text then
try perform_parse ()
with
Parser.Error -> message ~at:`verbose (Printf.sprintf "parsing got error parse.error"); None
| Syntaxerr.Error _ -> None
else match file_type with
| Interface -> Some (MkParseTree (Intf []))
| Implementation -> Some (MkParseTree (Impl []))
let calculate_region mi ma structure_list _ (* dirty_region *) =
(* first split the list of structure-items by whether they are invalid or not *)
let is_invalid ms2 me2 =
let region_contains s1 e1 s2 e2 =
let open Position in
(((s1 <= s2) && (s2 <= e1)) ||
((s1 <= e2) && (e2 <= e1)) ||
((s2 <= s1) && (s1 <= e2)) ||
((s2 <= e1) && (e1 <= e2))
) in
match Marker.position ms2, Marker.position me2 with
| Some s2, Some e2 ->
region_contains mi ma s2 e2
| _ -> true in
let (pre, invalid) =
List.split_while ~f:(fun ({ start_mark; end_mark; _ }, _) ->
not @@ is_invalid start_mark end_mark
) structure_list in
let invalid = List.rev invalid in
let (post, inb) =
List.split_while ~f:(fun ({ start_mark; end_mark; _ }, _) ->
not @@ is_invalid start_mark end_mark
) invalid in
let post = List.rev post in
(pre,inb,post)
let calculate_start_end f mi ma pre_edit_region invalid_region post_edit_region =
let start_region =
match List.last pre_edit_region with
| Some (_, st) ->
let (iterator,get_bounds) = Ast_transformer.bounds_iterator () in
f iterator st;
let (_,c) = get_bounds () in
byte_of_position_safe c
| None ->
match invalid_region with
| (_,st) :: _ ->
let (iterator,get_bounds) = Ast_transformer.bounds_iterator () in
f iterator st;
let (_,c) = get_bounds () in
byte_of_position_safe c
| [] -> mi
in
let end_region =
match post_edit_region with
| (_, st) :: _ ->
let (iterator,get_bounds) = Ast_transformer.bounds_iterator () in
f iterator st;
let (_,c) = get_bounds () in
byte_of_position_safe c
| [] ->
match List.last invalid_region with
| Some (_,st) ->
let (iterator,get_bounds) = Ast_transformer.bounds_iterator () in
f iterator st;
let (_,c) = get_bounds () in
byte_of_position_safe c
| None -> ma in
(start_region,end_region)
let abstract_rebuild_region f start_region end_region pre_edit_region post_edit_region =
(* first, attempt to parse the exact modified region *)
match parse_current_buffer ~start:start_region ~end_:end_region Filetype.Interface
with
| Some v -> let reparsed_range = f v in pre_edit_region @ reparsed_range @ post_edit_region
| None ->
(* otherwise, try to reparse from the start to the end *)
match parse_current_buffer ~start:start_region Filetype.Interface with
| Some v -> let reparsed_range = f v in pre_edit_region @ reparsed_range
| None ->
(* otherwise, try to reparse from the start to the end *)
match parse_current_buffer Filetype.Interface
with
| Some v -> let reparsed_range = f v in reparsed_range
| None -> pre_edit_region @ post_edit_region
let rebuild_intf_parse_tree min max structure_list dirty_region =
let mi,ma = byte_of_position_safe min, byte_of_position_safe max in
let (pre_edit_region,invalid_region,post_edit_region) =
calculate_region mi ma structure_list dirty_region in
let (start_region,end_region) =
calculate_start_end
(fun iterator st -> iterator.signature_item iterator st)
mi ma pre_edit_region invalid_region post_edit_region in
abstract_rebuild_region
(fun (MkParseTree tree) ->
match tree with
| Impl _ -> assert false
| Intf reparsed_range -> reparsed_range)
start_region end_region pre_edit_region post_edit_region
let rebuild_impl_parse_tree min max structure_list dirty_region =
let mi,ma = byte_of_position_safe min, byte_of_position_safe max in
let (pre_edit_region,invalid_region,post_edit_region) =
calculate_region mi ma structure_list dirty_region in
let (start_region,end_region) =
calculate_start_end
(fun iterator st -> iterator.structure_item iterator st)
mi ma pre_edit_region invalid_region post_edit_region in
abstract_rebuild_region
(fun (MkParseTree tree) ->
match tree with
| Impl reparsed_range -> reparsed_range
| Intf _ -> assert false)
start_region end_region pre_edit_region post_edit_region
end
module DirtyRegion = struct
(** Tracks the ast - either clean, or dirty (and whether it has
been changed since last compile attempt) *)
type t =
| Clean of parse_tree
| Dirty of (parse_tree option * bool)
let get_dirty_region = function
| Clean _ -> None
| Dirty _ -> Some (0,-1)
let is_dirty = function
| Clean _ -> false
| _ -> true
(** creates a clean dirty region from a parse tree *)
let create tree = Clean tree
(** updates the parse tree to denote the range of the dirty region *)
let update (s:t) (_s,_e,_l: (int * int * int)) : t =
(* todo: track detailed changes *)
match (s : t) with
| Clean tree -> Dirty (Some tree, true)
| Dirty (tree,_) -> Dirty (tree, true)
(** builds an updated parse_tree (updating any dirty regions) *)
let to_tree (dr:t) (_file_type: Filetype.t) : parse_tree option =
match dr with
| Clean tree -> Some tree
| Dirty _ ->
TreeBuilder.parse_current_buffer _file_type
(** returns the parse tree - even if it may be dirty *)
let to_tree_immediate (dr:t) (_file_type: Filetype.t) : parse_tree option =
match dr with
| Clean tree -> Some tree
| Dirty (tree, _) -> tree
end
(** type of state of plugin - pre-validation *)
type t = {
(** file type of the current buffer *)
file_type: Filetype.t;
(** parse tree of the current buffer + any dirty regions *)
parse_tree: DirtyRegion.t;
}
module Validated = struct
(** type of valid state of plugin *)
type s = {
(** file type of the current buffer *)
file_type: Filetype.t;
(** parse tree of the current buffer *)
parse_tree: parse_tree;
}
(** builds a validated instance of gopcaml-state -
returning a new copy of the state if it has changed*)
let of_state (state: t) =
let (>>=) x f = Option.bind ~f x in
let should_store = ref false in
(DirtyRegion.to_tree state.parse_tree state.file_type) >>= fun parse_tree ->
if DirtyRegion.is_dirty state.parse_tree then should_store := true;
if !should_store then
Some ({file_type=state.file_type;
parse_tree},
Some ({file_type=state.file_type;
parse_tree = (DirtyRegion.create parse_tree)}:t))
else
Some ({file_type=state.file_type; parse_tree}, None)
(** attempts to retrieve the state immediately - even if it is old or outdated *)
let of_state_immediate ({ file_type; parse_tree }:t) =
(match parse_tree with
| DirtyRegion.Clean tree -> Some tree
| DirtyRegion.Dirty (tree,_) -> tree
)
|> Option.map ~f:(fun tree -> ({file_type; parse_tree = tree}))
(** attempts to retrieve the state immediately - even if it is old or outdated *)
let try_ensure ({ file_type; parse_tree } as state :t) =
(match parse_tree with
| DirtyRegion.Clean _ -> None, true
| DirtyRegion.Dirty (_,false) -> None, false
| DirtyRegion.Dirty (tree,true) ->
let parse_tree = DirtyRegion.to_tree state.parse_tree state.file_type in
begin
match parse_tree with
| Some tree ->
Some ({file_type; parse_tree = (DirtyRegion.create tree)} :t), true
| None ->
Some ({ file_type; parse_tree = DirtyRegion.Dirty (tree,false)}:t), false
end
)
type t = s
end
(** elisp type for state of system *)
let ty : t Value.Type.t =
Caml_embed.create_type
(Type_equal.Id.create
~name:"gopcaml-state"
Sexplib0.Sexp_conv.sexp_of_opaque)
(* let default = {
* file_type = Interface;
* parse_tree = DirtyRegion.Dirty (None,false);
* } *)
end
(** sets up the gopcaml-mode state - intended to be called by the startup hook of gopcaml mode*)
let setup_gopcaml_state
~state_var ~interface_extension_var
~implementation_extension_var =
let current_buffer = Current_buffer.get () in
(* we've set these values in their definition, so it doesn't make sense for them to be non-present *)
let interface_extensions =
Customization.value interface_extension_var in
let implementation_extensions =
Customization.value implementation_extension_var in
message ~at:`verbose "Building initial state";
let file_type =
let inferred =
State.TreeBuilder.retrieve_current_file_type
~implementation_extensions ~interface_extensions in
match inferred with
| Some vl -> vl
| None ->
message ~at:`info "Could not infer the ocaml type (interface or \
implementation) of the current file - will attempt
to proceed by defaulting to implementation.";
State.Filetype.Implementation
in
let parse_tree = State.TreeBuilder.parse_current_buffer file_type in
if Option.is_none parse_tree then
message ~at:`info "Could not build parse tree - please ensure that the \
buffer is syntactically correct and call \
gopcaml-initialize to enable the full POWER of syntactic \
editing.";
let state = State.{
file_type = file_type;
parse_tree = match parse_tree with
None -> DirtyRegion.Dirty (None, false)
| Some tree -> DirtyRegion.create tree;
} in
Buffer_local.set state_var (Some state) current_buffer
(** retrieve the gopcaml state *)
let get_gopcaml_file_type ?current_buffer ~state_var () =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
let state = Buffer_local.get_exn state_var current_buffer in
let file_type_name = State.Filetype.to_string state.State.file_type in
file_type_name
(** update the file type of the variable *)
let set_gopcaml_file_type ?current_buffer ~state_var file_type =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
let state = Buffer_local.get_exn state_var current_buffer in
let state = State.{state with parse_tree=Dirty (None, true); file_type = file_type } in
Buffer_local.set state_var (Some state) current_buffer
[@@warning "-23"]
(** from a list of expressions, finds the enclosing one *)
let find_enclosing_expression list point =
let open State in
let (left,remain) = List.split_while list ~f:(fun (region,_) ->
let (>>=) v f = Option.bind ~f v in
let contains =
(Marker.position region.start_mark) >>= fun start_position ->
(Marker.position region.end_mark) >>= fun end_position ->
Some (not @@ Position.between ~low:start_position ~high:end_position point) in
Option.value ~default:true contains) in
let remove_region = List.map ~f:(fun (_,b) -> b) in
match remain with
| (_,current) :: right -> Some (remove_region left,current, remove_region right)
| [] -> None
(** from a list of expressions, returns the nearest expression *)
let find_nearest_expression list point =
let open State in
match find_enclosing_expression list point with
| None ->
(* no enclosing expression - hence, find nearest expression *)
let (>>=) v f = Option.bind ~f v in
let distance ((region,_) as value) =
let distance =
(Marker.position region.start_mark) >>= fun start_position ->
(Marker.position region.end_mark) >>= fun end_position ->
Some (min (abs (Position.to_int start_position - Position.to_int point))
(abs (Position.to_int end_position - Position.to_int point))) in
distance, value in
let regions = List.map list ~f:distance in
(List.min_elt ~compare:(fun (d,_) (d',_) ->
let d = match d with Some v -> v | None -> Int.max_value in
let d' = match d' with Some v -> v | None -> Int.max_value in
Int.compare d d') regions) >>= fun (min, _) ->
let eq = Option.equal (Int.equal) in
let remove_meta (_,(_,v)) = v in
begin match List.split_while regions ~f:(fun (d,_) -> not @@ eq d min) with
| (left, current :: right) ->
Some (
List.map ~f:remove_meta left,
remove_meta current,
List.map ~f:remove_meta right)
| _ -> None
end
| v -> v
let list_split_last ls =
let rec loop ls acc =
match ls with
| h :: [] -> Some (h,List.rev acc)
| h :: t -> loop t (h :: acc)
| [] -> None in
loop ls []
let build_zipper (state: State.Validated.t) point =
let find_nearest_prev_expression f list =
let (>>=) v f = Option.bind ~f v in
(find_nearest_expression list point) >>= fun (left,current,right) ->
if (f current) = (Position.to_byte_position point)
then begin
match list_split_last left with
| Some (last,left) -> Some (left, last, current::right)
| None -> Some (left,current,right)
end
else Some (left,current,right)
in
let sif ({ psig_loc = { loc_start; _ }; _ }:Parsetree.signature_item) = loc_start.pos_cnum in
let stf ({ pstr_loc = { loc_start; _ }; _ }:Parsetree.structure_item) = loc_start.pos_cnum in
begin match state.parse_tree with
| (State.MkParseTree (State.Impl si_list)) ->
find_nearest_prev_expression stf si_list
|> Option.map ~f:(fun (left,current,right) ->
Ast_zipper.make_zipper_impl left current right )
| (State.MkParseTree (State.Intf si_list)) ->
find_nearest_prev_expression sif si_list
|> Option.map ~f:(fun (left,current,right) ->
Ast_zipper.make_zipper_intf left current right
)
end
let find_enclosing_structure (state: State.Validated.t) point : State.parse_item option =
let open State in
let open Validated in
let find_enclosing_expression list =
List.find list ~f:(fun (region,_) ->
let (>>=) v f = Option.bind ~f v in
let contains =
(Marker.position region.start_mark) >>= fun start_position ->
(Marker.position region.end_mark) >>= fun end_position ->
Some (Position.between ~low:start_position ~high:end_position point) in
Option.value ~default:false contains) in
match state.parse_tree with
| (State.MkParseTree (State.Impl si_list)) ->
find_enclosing_expression si_list |> Option.map ~f:(fun x -> State.MkParseItem (State.ImplIt x))
| (State.MkParseTree (State.Intf si_list)) ->
find_enclosing_expression si_list |> Option.map ~f:(fun x -> State.MkParseItem (State.IntfIt x))
(* determines whether we are inside a letdef *)
let inside_let_def state point =
let contains ({ loc_start; loc_end; _ }: Location.t) =
(loc_start.pos_cnum <= point) && (point <= loc_end.pos_cnum)
in
let rec is_let_def_struct ({pstr_desc;_}: Parsetree.structure_item) = (match pstr_desc with
| Parsetree.Pstr_eval (expr, _) -> is_let_def_expr expr
| Parsetree.Pstr_value (_, vbs) ->
List.fold ~init:false ~f:(fun acc value -> acc || is_in_value_binding value) vbs
| Parsetree.Pstr_module mb -> is_let_def_mod_expr mb.pmb_expr
| Parsetree.Pstr_recmodule mods ->
List.fold ~init:false ~f:(fun acc value -> acc || is_let_def_mod_expr value.pmb_expr) mods
| Parsetree.Pstr_class_type cty_decl ->
List.fold ~init:false ~f:(fun acc { pci_expr; _ } -> acc || is_let_def_class_type pci_expr)
cty_decl
| Parsetree.Pstr_class c_decls ->
List.fold ~init:false ~f:(fun acc { pci_expr; _ } -> acc || is_let_def_class_expr pci_expr)
c_decls
| _ -> false)
and is_let_def_sig ({ psig_desc; psig_loc }: Parsetree.signature_item) =
if contains psig_loc then (match psig_desc with
| Parsetree.Psig_module { pmd_type; _ } -> is_let_def_mod_type pmd_type
| Parsetree.Psig_recmodule decls ->
List.fold ~init:false ~f:(fun acc { pmd_type; _ } -> acc || is_let_def_mod_type pmd_type)
decls
| Parsetree.Psig_modtype { pmtd_type; _ } ->
Option.map ~f:is_let_def_mod_type pmtd_type |> Option.value ~default:false
| Parsetree.Psig_include { pincl_mod; _ } -> is_let_def_mod_type pincl_mod
| Parsetree.Psig_class c_decls ->
List.fold ~init:false ~f:(fun acc { pci_expr; _ } -> acc || is_let_def_class_type pci_expr)
c_decls
| Parsetree.Psig_class_type c_decls ->
List.fold ~init:false ~f:(fun acc { pci_expr; _ } -> acc || is_let_def_class_type pci_expr)
c_decls
| _ -> false
) else false
and is_in_value_binding ({ pvb_expr; pvb_loc; _ }: Parsetree.value_binding) =
if contains pvb_loc then contains pvb_expr.pexp_loc else false
and is_let_def_case ({ pc_guard; pc_rhs;_ }: Parsetree.case) =
(Option.map ~f:is_let_def_expr pc_guard |> Option.value ~default:false) || (is_let_def_expr pc_rhs)
and is_let_def_mod_type ({ pmty_desc; pmty_loc; _ }: Parsetree.module_type) =
if contains pmty_loc then (match pmty_desc with
| Parsetree.Pmty_functor (omt, mt) ->
(match omt with
| Parsetree.Unit -> false
| Parsetree.Named (_, omt) -> is_let_def_mod_type omt) ||
is_let_def_mod_type mt
| Parsetree.Pmty_with (mt, _) -> is_let_def_mod_type mt
| Parsetree.Pmty_typeof mexpr -> is_let_def_mod_expr mexpr
| _ -> false) else false
and is_let_def_mod_expr ({ pmod_desc; pmod_loc; _ }: Parsetree.module_expr) =
if contains pmod_loc then
(match pmod_desc with
| Parsetree.Pmod_structure st ->
List.fold ~init:false ~f:(fun acc value -> acc || is_let_def_struct value) st
| Parsetree.Pmod_functor (mt, mexpr) ->
(match mt with
| Parsetree.Unit -> false
| Parsetree.Named (_, mt) -> is_let_def_mod_type mt) ||
is_let_def_mod_expr mexpr
| Parsetree.Pmod_constraint (mexpr, mt) ->
is_let_def_mod_expr mexpr || is_let_def_mod_type mt
| Parsetree.Pmod_apply (mexp1, mexp2) ->
is_let_def_mod_expr mexp1 || is_let_def_mod_expr mexp2
| Parsetree.Pmod_unpack expr -> is_let_def_expr expr
| _ -> false)
else false
and is_let_def_class_field_type_kind ({ pctf_desc; pctf_loc; _ }: Parsetree.class_type_field) =
if contains pctf_loc then (match pctf_desc with
| Parsetree.Pctf_inherit ct -> is_let_def_class_type ct
| _ -> false) else false
and is_let_def_class_signature ({ pcsig_fields;_ }: Parsetree.class_signature) =
List.fold ~init:false pcsig_fields
~f:(fun acc value -> acc || is_let_def_class_field_type_kind value)
and is_let_def_class_type ({ pcty_desc; pcty_loc; _ }: Parsetree.class_type) =
if contains pcty_loc then
(match pcty_desc with
| Parsetree.Pcty_signature cs -> is_let_def_class_signature cs
| Parsetree.Pcty_arrow (_, _, cty) -> is_let_def_class_type cty
| Parsetree.Pcty_open (_, cty) ->
is_let_def_class_type cty
| _ -> false
)
else false
and is_let_def_class_expr ({ pcl_desc; pcl_loc; _ }: Parsetree.class_expr) =
if contains pcl_loc then (match pcl_desc with
| Parsetree.Pcl_structure cs -> is_let_def_class_structure cs
| Parsetree.Pcl_fun (_, oexpr, _, clsexpr) ->
(Option.map ~f:is_let_def_expr oexpr |> Option.value ~default:false) ||
is_let_def_class_expr clsexpr
| Parsetree.Pcl_apply (clsexpr, fields) ->
is_let_def_class_expr clsexpr ||
List.fold ~init:false ~f:(fun acc (_,value) -> acc || is_let_def_expr value) fields
| Parsetree.Pcl_let (_, vbs, cexp) ->
List.fold ~init:false ~f:(fun acc value -> acc || is_in_value_binding value) vbs
|| is_let_def_class_expr cexp
| Parsetree.Pcl_constraint (cexp, ctyp) ->
is_let_def_class_expr cexp || is_let_def_class_type ctyp
| Parsetree.Pcl_open (_, cexp) -> is_let_def_class_expr cexp
| _ -> false) else false
and is_let_def_class_field_kind cfk = match cfk with
| Parsetree.Cfk_virtual _ -> false
| Parsetree.Cfk_concrete (_, exp) -> is_let_def_expr exp
and is_let_def_class_field ({ pcf_desc; pcf_loc; _ }: Parsetree.class_field) =
if contains pcf_loc then (match pcf_desc with
| Parsetree.Pcf_inherit (_, cexp, _) -> is_let_def_class_expr cexp
| Parsetree.Pcf_val (_, _, cfk) -> is_let_def_class_field_kind cfk
| Parsetree.Pcf_method (_, _, cfk) -> is_let_def_class_field_kind cfk
| Parsetree.Pcf_initializer exp -> is_let_def_expr exp
| _ -> false
) else false
and is_let_def_class_structure ({ pcstr_fields; _ }: Parsetree.class_structure) =
List.fold ~init:false pcstr_fields ~f:(fun acc value -> acc || is_let_def_class_field value)
and is_let_def_expr ({ pexp_desc; pexp_loc; _ }:Parsetree.expression) =
if contains pexp_loc then
(match pexp_desc with
(* check if in any of the value bindings *)
| Parsetree.Pexp_let (_, vbs, expr) ->
List.fold ~init:false ~f:(fun acc value -> acc || is_in_value_binding value) vbs
|| is_let_def_expr expr
| Parsetree.Pexp_function cases ->
List.fold ~init:false ~f:(fun acc value -> acc || is_let_def_case value) cases
| Parsetree.Pexp_apply (expr, args) ->
is_let_def_expr expr
|| List.fold ~init:false ~f:(fun acc (_, value) -> acc || is_let_def_expr value) args
| Parsetree.Pexp_try (expr, cases)
| Parsetree.Pexp_match (expr, cases) ->
is_let_def_expr expr ||
List.fold ~init:false ~f:(fun acc value -> acc || is_let_def_case value) cases
| Parsetree.Pexp_fun (_, oe1, _, e2) ->
(Option.map ~f:is_let_def_expr oe1 |> Option.value ~default:false) || is_let_def_expr e2
| Parsetree.Pexp_open (_, expr)
| Parsetree.Pexp_newtype (_, expr)
| Parsetree.Pexp_lazy expr
| Parsetree.Pexp_poly (expr, _)
| Parsetree.Pexp_assert expr
| Parsetree.Pexp_setinstvar (_, expr)
| Parsetree.Pexp_send (expr, _)
| Parsetree.Pexp_field (expr, _)
| Parsetree.Pexp_coerce (expr, _, _)
| Parsetree.Pexp_constraint (expr, _)
| Parsetree.Pexp_construct (_, Some expr)
| Parsetree.Pexp_variant (_, Some expr) -> is_let_def_expr expr
| Parsetree.Pexp_record (fields, oe1) ->
List.fold ~init:false ~f:(fun acc (_, value) -> acc || is_let_def_expr value) fields ||
(Option.map ~f:is_let_def_expr oe1 |> Option.value ~default:false)
| Parsetree.Pexp_tuple arr
| Parsetree.Pexp_array arr ->
List.fold ~init:false ~f:(fun acc value -> acc || (is_let_def_expr value)) arr
| Parsetree.Pexp_ifthenelse (e1, e2, oe3) ->
is_let_def_expr e1 || is_let_def_expr e2 ||
(Option.map ~f:is_let_def_expr oe3 |> Option.value ~default:false)
| Parsetree.Pexp_setfield (e1, _, e2)
| Parsetree.Pexp_while (e1, e2)
| Parsetree.Pexp_sequence (e1, e2) -> is_let_def_expr e1 || is_let_def_expr e2
| Parsetree.Pexp_for (_, e1, e2, _, e3) ->
List.fold ~init:false ~f:(fun acc value -> acc || (is_let_def_expr value)) [e1;e2;e3]
| Parsetree.Pexp_override overrides ->
List.fold ~init:false ~f:(fun acc (_, value) -> acc || (is_let_def_expr value)) overrides
| Parsetree.Pexp_letmodule (_, mod_expr, expr) ->
is_let_def_mod_expr mod_expr || is_let_def_expr expr
| Parsetree.Pexp_letexception (_, expr) -> is_let_def_expr expr
| Parsetree.Pexp_object cs -> is_let_def_class_structure cs
| Parsetree.Pexp_pack mexp -> is_let_def_mod_expr mexp
| Parsetree.Pexp_letop _ -> true
| _ -> false
)
else false
in
find_enclosing_structure state (Position.of_int_exn point)
|> Option.map ~f:(fun (State.MkParseItem it) ->
match it with
| State.ImplIt (_, st) -> is_let_def_struct st
| State.IntfIt (_, si) -> is_let_def_sig si
)
let apply_iterator (item: State.parse_item) iter f =
let open State in
let (MkParseItem elem) = item in
begin match elem with
| ImplIt (_,it) -> iter.Ast_iterator.structure_item iter it
| IntfIt (_, it) -> iter.Ast_iterator.signature_item iter it
end;
f ()
(** returns a tuple of points enclosing the current expression *)
let find_enclosing_bounds (state: State.Validated.t) ~point =
find_enclosing_structure state point
|> Option.bind ~f:begin fun expr ->
let (iter,getter) = Ast_transformer.enclosing_bounds_iterator (Position.to_byte_position point) () in
apply_iterator expr iter getter
|> Option.map ~f:(fun (a,b) -> (byte_of_position_safe (a + 1), byte_of_position_safe (b + 1)))
end
(** returns a tuple of points enclosing the current structure *)
let find_enclosing_structure_bounds (state: State.Validated.t) ~point =
find_enclosing_structure state point
|> Option.bind ~f:begin fun expr -> let (State.MkParseItem expr) = expr in
let region = match expr with
| ImplIt (r,_) -> r
| IntfIt (r,_) -> r in
match Marker.position region.start_mark,Marker.position region.end_mark with
| Some s, Some e -> Some (Position.add s 1, Position.add e 1)
| _ -> None
end
(** updates the dirty region of the parse tree *)
let update_dirty_region ?current_buffer ~state_var (s,e,l) =
let (>>=) x f = ignore @@ Option.map ~f x in
let open State in
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
(Buffer_local.get state_var current_buffer) >>= fun state ->
let parse_tree = DirtyRegion.update state.parse_tree (s,e,l) in
let state = {state with parse_tree = parse_tree} in
Buffer_local.set state_var (Some state) current_buffer
(** retrieves the dirty region if it exists *)
let get_dirty_region ?current_buffer ~state_var () =
let open State in
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
let state = Buffer_local.get_exn state_var current_buffer in
DirtyRegion.get_dirty_region state.parse_tree
(** retrieves the gopcaml state value, attempting to construct the
parse tree if it has not already been made *)
let retrieve_gopcaml_state ?current_buffer ~state_var () =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
let state = Buffer_local.get_exn state_var current_buffer in
let (>>=) x f = Option.bind ~f x in
(State.Validated.of_state state) >>= fun (v_state,state) ->
if Option.is_some state then Buffer_local.set state_var state current_buffer;
Some v_state
(** retrieves the gopcaml state value, attempting to construct the
parse tree if it has not already been made *)
let check_gopcaml_state_available ?current_buffer ~state_var () =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
let state = Buffer_local.get_exn state_var current_buffer in
let (state,ensured) = State.Validated.try_ensure state in
if Option.is_some state then Buffer_local.set state_var state current_buffer;
ensured
(** retrieves the gopcaml state value, without attempting to construct the
parse tree if it has not already been made *)
let retrieve_gopcaml_state_immediate ?current_buffer ~state_var () =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
let state = Buffer_local.get_exn state_var current_buffer in
State.Validated.of_state_immediate state
(** retrieve the points enclosing structure at the current position *)
let retrieve_enclosing_structure_bounds ?current_buffer ~state_var point =
retrieve_gopcaml_state ?current_buffer ~state_var ()
|> Option.bind ~f:(find_enclosing_structure_bounds ~point)
(** retrieve the points enclosing expression at the current position *)
let retrieve_enclosing_bounds ?current_buffer ~state_var point =
retrieve_gopcaml_state ?current_buffer ~state_var ()
|> Option.bind ~f:(find_enclosing_bounds ~point)
let print_zipper =
Option.map ~f:(fun zipper ->
message ~at:`debug (Ast_zipper.describe_current_item zipper);
zipper)
(** retrieve a zipper expression at the current position *)
let build_zipper_enclosing_point ?direction ?current_buffer ~state_var ~zipper_var point line =
let direction = match direction with
| None -> false
| Some v -> v in
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
retrieve_gopcaml_state ~current_buffer ~state_var ()
|> Option.bind ~f:(fun state ->
let zipper = build_zipper state point
|> Option.map ~f:(Ast_zipper.move_zipper_to_point
(Position.to_byte_position @@ position_sub1 point)
line direction) in
Buffer_local.set zipper_var zipper current_buffer;
zipper)
|> print_zipper
|> Option.map ~f:Ast_zipper.to_bounds
|> Option.map ~f:(fun (st,ed) ->
byte_of_position_safe (st + 1), byte_of_position_safe (ed + 1)
)
(** retrieve a zipper enclosing structure at the current position *)
let build_zipper_broadly_enclosing_point ?current_buffer ~state_var ~zipper_var point line =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
retrieve_gopcaml_state ~current_buffer ~state_var ()
|> Option.bind ~f:(fun state ->
let zipper = build_zipper state point
|> Option.map ~f:(Ast_zipper.move_zipper_broadly_to_point
(Position.to_byte_position @@ position_sub1 point)
line false) in
Buffer_local.set zipper_var zipper current_buffer;
zipper)
|> print_zipper
|> Option.map ~f:Ast_zipper.to_bounds
|> Option.map ~f:(fun (st,ed) ->
byte_of_position_safe (st + 1), byte_of_position_safe (ed + 1)
)
(** returns the point corresponding to the start of the nearest defun (or respective thing in ocaml) *)
let find_nearest_defun ?current_buffer ~state_var point line =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
retrieve_gopcaml_state ~current_buffer ~state_var ()
|> Option.bind ~f:(fun state -> build_zipper state (position_sub1 point) )
|> Option.bind ~f:(fun zipper -> Ast_zipper.find_nearest_definition_item_bounds
(Position.to_byte_position @@ position_sub1 point)
(line + 1)
false
zipper)
|> Option.map ~f:(fun x -> x + 1)
(** returns the point corresponding to the start of the nearest defun (or respective thing in ocaml) *)
let find_nearest_defun_end ?current_buffer ~state_var point line =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
retrieve_gopcaml_state ~current_buffer ~state_var ()
|> Option.bind ~f:(fun state ->
build_zipper state (position_sub1 point)
)
|> Option.bind ~f:(fun zipper ->
let start = (Position.to_byte_position @@ position_sub1 point) in
Ast_zipper.find_nearest_definition_item_bounds
start
line
true
zipper)
|> Option.map ~f:(fun x -> x + 1)
(** returns the point corresponding to the start of the nearest letdef (or respective thing in ocaml) *)
let find_nearest_letdef ?current_buffer ~state_var point line =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
retrieve_gopcaml_state ~current_buffer ~state_var ()
|> Option.bind ~f:(fun state -> build_zipper state (position_sub1 point))
|> Option.map ~f:(Ast_zipper.move_zipper_to_point
(Position.to_byte_position Position.(sub point 1)) line false )
|> Option.bind ~f:(fun zipper -> Ast_zipper.find_nearest_letdef
(Position.to_byte_position Position.(sub point 1))
zipper)
|> Option.map ~f:(fun x -> x + 1)
(** returns the point corresponding to the start of the nearest pattern (or respective thing in ocaml) *)
let find_nearest_pattern ?current_buffer ~state_var point line =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
retrieve_gopcaml_state ~current_buffer ~state_var ()
|> Option.bind ~f:(fun state -> build_zipper state (position_sub1 point))
|> Option.map ~f:( Ast_zipper.move_zipper_to_point
(Position.to_byte_position Position.(sub point 1)) line false )
|> Option.bind ~f:(fun zipper -> Ast_zipper.find_nearest_pattern
(Position.to_byte_position Position.(sub point 1))
zipper)
|> Option.map ~f:(fun x -> x + 1)
(** returns whether the point is inside a let def (and thus when
expanding let we should include an in) *)
let inside_defun ?current_buffer ~state_var point =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
retrieve_gopcaml_state_immediate ~current_buffer ~state_var ()
|> Option.bind ~f:(fun state -> inside_let_def state point)
(** retrieve zipper *)
let retrieve_zipper ?current_buffer ~zipper_var =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
Buffer_local.get zipper_var current_buffer
(** delete zipper *)
let delete_zipper ?current_buffer ~zipper_var () =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
Buffer_local.set zipper_var None current_buffer
(** delete state *)
let delete_state ?current_buffer ~state_var () =
let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in
Buffer_local.set state_var None current_buffer
let abstract_zipper_to_bounds zipper = zipper
|> Option.map ~f:Ast_zipper.to_bounds
|> Option.map ~f:(fun (st,ed) ->
byte_of_position_safe (st + 1), byte_of_position_safe (ed + 1)
)
(** retrieve bounds for current zipper *)
let retrieve_zipper_bounds ?current_buffer ~zipper_var () =
retrieve_zipper ?current_buffer ~zipper_var
|> abstract_zipper_to_bounds
(** checks whether the current zipper item is a top-level item *)
let check_zipper_toplevel ?current_buffer ~zipper_var () =
retrieve_zipper ?current_buffer ~zipper_var
|> Option.map ~f:(Ast_zipper.zipper_is_top_level)
let check_zipper_toplevel_parent ?current_buffer ~zipper_var () =