Commits

camlspotter  committed 36410f3 Merge

port from dev

  • Participants
  • Parent commits 6a6cb74, 0274364

Comments (0)

Files changed (9)

 
 OCAMLINCLUDES +=
 
-OCAMLFLAGS    += -annot -w Aelz-9
+OCAMLFLAGS    = -annot -w A-4-9 -warn-error A-4-9
 OCAMLCFLAGS   +=
 OCAMLOPTFLAGS +=
 OCAML_LINK_FLAGS +=
     reader
     tokenstr
     machine
+    args
     main
 
 lexer.cmi: parser.cmi
+let paths, debug, lines, showstate, cursor =
+  let rev_paths = ref [] in
+  let debug = ref false in
+  let lines = ref None in
+  let showstate = ref false in
+  let cursor = ref None in
+  Arg.parse [
+    ("-debug", Arg.Set debug, "debugging");
+    ("-lines", Arg.String (fun s ->
+      try
+        let pos = String.index s '-' in
+        let (start,end_) = (int_of_string (String.sub s 0 pos),
+                            int_of_string (String.sub s (pos+1) (String.length s - pos - 1))) in
+        if start <= 0 || end_ <= 0 || start > end_ then
+          failwith (Printf.sprintf "Wrong -lines specification: %s" s);
+        lines := Some (start, end_)
+      with
+      | _ -> failwith (Printf.sprintf "Wrong -lines specification: %s" s)),
+     "lines, ex. 10-12") ;
+    ("-cursor", Arg.String (fun s ->
+      try
+        let pos = String.index s ':' in
+        let (rows,cols) = (int_of_string (String.sub s 0 pos),
+                           int_of_string (String.sub s (pos+1) (String.length s - pos - 1))) in
+        if rows <= 0 || cols < 0 then
+          failwith (Printf.sprintf "Wrong -cursor specification: %s" s);
+        cursor := Some (rows, cols)
+      with
+      | _ -> failwith (Printf.sprintf "Wrong -cursor specification: %s" s)),
+     "cursor position, ex. 10:12") ;
+    ("-show-state", Arg.Set showstate, "show state at the last");
+  ] (fun s -> rev_paths := s :: !rev_paths) "indent paths";
+  let paths = List.rev !rev_paths in
+  let paths = if paths = [] then [""] else paths in (* CR jfuruse: ugly *)
+  begin match paths, !lines with
+  | [], _ -> assert false
+  | [_], _ -> ()
+  | _, Some _ -> failwith "Region can be specified with at most one file"
+  | _ -> ()
+  end;
+  paths, !debug, !lines, !showstate, !cursor
 
   type t = elt list with sexp_of
 
-  let rec indent last_indent  = function
+  (* CR jfuruse: strange *)
+  let rec indent _last_indent  = function
     | [] -> 0
     | { indent = n } :: _ -> n
 end
 
 module State = struct
   type t = {
-    modified : bool; (* Has the source code ever modified ? *)
+    modified : bool;   (* Has the source code ever modified ? *)
     orig_indent : int; (* The original indent of the current line *)
     last_indent : int; (* At line head, first pass: the fixed indent of the last line
                           At line head, snd pass: the fixed indent of the current line
       | GREATERRBRACKET|GREATERRBRACE|FUNCTOR|FUNCTION|FUN|FOR|FALSE
       | EXTERNAL|EXCEPTION|EOF|END|DOTDOT|DOT|DONE|CONSTRAINT|COLONGREATER
       | COLON|CLASS|BARRBRACKET|BAR|BANG|BACKQUOTE|ASSERT|AS|AND
-       -> true
+          -> true
 
       | _ -> false
 
   | Some (i, _) when Region.lnum i.Tokenstr.region <> lnum -> false
   | Some (i, str) ->
       match i.Tokenstr.token with
+      | COMMENT -> lparen_read_ahead lnum str
       | FUN -> false
       | FUNCTION -> false
-      | COMMENT -> lparen_read_ahead lnum str
       | _ -> true
 
 let rec lbrace_read_ahead lnum str =
         bases,
         { k = KModule cols; indent = cols + 2; } :: bases
 
+    | VAL ->
+        let bases = unwind_top bases0 in
+        bases,
+        { k = KVal; indent = cols + 2; } :: bases
+
     | LET when is_top_let state.last_token ->
         let bases = unwind_top bases0 in
         bases,
     | LET ->
         bases0, { k = KLet (`Local, cols); indent = cols + 2; } :: bases0
 
-    | VAL ->
-        let bases = unwind_top bases0 in
-        bases,
-        { k = KVal; indent = cols + 2; } :: bases
-
     | EQUAL ->
         (* CR jfuruse: TODO
            - pre bases
            - for non definition equals *)
         let rec f bases = match bases with
           (* Definition equal rolls things back to its head *)
-          | {k = (KLet (_,cols) | KType cols | KModule cols) } :: _ ->
+          | {k = (KLet (_, _cols) | KType _cols | KModule _cols) } :: _ ->
               bases, bases
           (* Equal can exceed the following *)
           | { k = (KExpr _ | KNone) } :: bs -> f bs
           (* Equal cannot exceed the other *)
-          | _ :: bs -> bases0, bases0
+          | _ :: _bs -> bases0, bases0
           | [] -> [], []
         in
         f bases0
 
     | AND ->
         (* for let *)
-        (* recover the last let *)
+        (* recover the last let, type, module *)
         let rec f bases = match bases with
           | {k = (KLet (_,cols) | KType cols | KModule cols) } :: _ ->
               fix cols, bases
     | MINUSGREATER ->
         let rec f bases = match bases with
           | { k = (KWith cols) } :: _ ->
-              bases0,
+              fix (cols + 2),
               { k = KCaseArrow; indent = cols + 4; } :: bases
           | { k = (KFunction cols) } :: _ ->
-              bases0,
+              fix (cols + 2),
               { k = KCaseArrow; indent = cols + 6; } :: bases
           | { k = (KFun cols) } :: _ ->
-              bases0,
+              fix (cols + 2),
               { k = KCaseArrow; indent = cols + 2; } :: bases
           | [] -> bases0, bases0 (* if overrun, keep the original *)
           | _ :: bs -> f bs
         let rec f bases = match bases with
           | { k = (KParen cols | KBegin cols | KBracket cols | KBrace cols | KLet (_, cols)) | KTry cols | KMatch cols | KFun cols | KFunction cols } :: _ ->
               fix cols, bases
+          | { k = KCaseArrow } :: _ -> bases, bases
           | { k = (KThen cols | KElse cols ) } :: bs ->
               fix cols, bs
-          | { k = KExpr cols } :: bs ->
-              fix cols, bs
           | [] -> bases0, bases0 (* if overrun, keep the original *)
           | _ :: bs -> f bs
         in
   { state with bases = pre_bases },
   { state with bases = post_bases }
 
-let update_state state new_line fix_indent str orig_region t =
+let update_state state ~at_new_line ~fix_indent str orig_region t =
 
   (* If it is a new line + we need to fix the indent of the line, compute the line's indentation.
      Otherwise, we use the original state.
   *)
   let state' =
-    if fix_indent && new_line then
-      let pre, _ = token state str new_line orig_region t in
+    if fix_indent && at_new_line then
+      let pre, _ = token state str at_new_line orig_region t in
       { pre with last_indent = State.indent pre }
     else
       state
   let state = { state
                 with
                 last_indent = state'.last_indent
-              ; modified = state'.modified || orig_region <> fixed_region
+                ; modified = state'.modified || orig_region <> fixed_region
               }
   in
 
   (* Rerun [token] *)
-  token state str new_line fixed_region t
+  token state str at_new_line fixed_region t
 open Pos
-open Machine
+open Args
+module State = Machine.State
+module Stack = Machine.Stack
 
-let paths, debug, lines, showstate, cursor =
-  let rev_paths = ref [] in
-  let debug = ref false in
-  let lines = ref None in
-  let showstate = ref false in
-  let cursor = ref None in
-  Arg.parse [
-    ("-debug", Arg.Set debug, "debugging");
-    ("-lines", Arg.String (fun s ->
-      try
-        let pos = String.index s '-' in
-        let (start,end_) = (int_of_string (String.sub s 0 pos),
-                            int_of_string (String.sub s (pos+1) (String.length s - pos - 1))) in
-        if start <= 0 || end_ <= 0 || start > end_ then
-          failwith (Printf.sprintf "Wrong -lines specification: %s" s);
-        lines := Some (start, end_)
-      with
-      | _ -> failwith (Printf.sprintf "Wrong -lines specification: %s" s)),
-     "lines, ex. 10-12") ;
-    ("-cursor", Arg.String (fun s ->
-      try
-        let pos = String.index s ':' in
-        let (rows,cols) = (int_of_string (String.sub s 0 pos),
-                           int_of_string (String.sub s (pos+1) (String.length s - pos - 1))) in
-        if rows <= 0 || cols < 0 then
-          failwith (Printf.sprintf "Wrong -cursor specification: %s" s);
-        cursor := Some (rows, cols)
-      with
-      | _ -> failwith (Printf.sprintf "Wrong -cursor specification: %s" s)),
-     "cursor position, ex. 10:12") ;
-    ("-show-state", Arg.Set showstate, "show state at the last");
-  ] (fun s -> rev_paths := s :: !rev_paths) "indent paths";
-  let paths = List.rev !rev_paths in
-  let paths = if paths = [] then [""] else paths in (* CR jfuruse: ugly *)
-  begin match paths, !lines with
-  | [], _ -> assert false
-  | [_], _ -> ()
-  | _, Some _ -> failwith "Region can be specified with at most one file"
-  | _ -> ()
-  end;
-  paths, !debug, !lines, !showstate, !cursor
+module Sexp = Sexplib.Sexp (* No open Sexplib, since Parser corrides with Sexplib.Parser *)
 
-let check_lines l = function
+(** [l] is in the interested area or not? *)
+let check_line l = function
   | None -> `Inside
   | Some (start, end_) ->
       if l < start then `Before
       else if l <= end_ then `Inside
       else `Over
 
-module Printer = struct
+module Printer : sig
+  type t = (int * int) option
+  val print_debug  : t -> int-> string -> unit
+  val print_string : t -> int -> string -> unit
+end = struct
 
   type t = (int * int) option
 
-  let add_debug t lnum s = match check_lines lnum t with
+  let print_debug t lnum s = match check_line lnum t with
     | `Before | `Over -> ()
     | `Inside -> print_string s
 
-  let add_string t lnum s =
-    let add_line t lnum s = match check_lines lnum t with
+  (** Print a string [s] for the line number [lnum].
+      If the printing text exceeds the interested region,
+      It stops printing.
+
+      Currently it cannot print a string correctly if it has
+      different number of lines from the original.
+  *)
+  let print_string t lnum s =
+    let add_line t lnum s = match check_line lnum t with
       | `Before -> ()
       | `Over -> raise Exit
       | `Inside -> print_string s
       | Some s -> iter (lnum+1) s
       | None -> ()
     in
-    iter lnum s
+    try iter lnum s with Exit -> ()
 
 end
 
+open Tokenstr
+
 let indent_file path =
-  let printer = lines in
+  let print_string = Printer.print_string lines in
+  let print_debug = Printer.print_debug lines in
+
   let str = if path = "" then Tokenstr.of_channel stdin else Tokenstr.of_path path in
 
+  let flush_remaining_space info =
+    print_string (Region.lnum (fst info.space)) (snd info.space)
+  in
+
   let rec loop last_orig_region state str = match Tokenstr.destr str with
     | None -> state
 
-    | Some (({Tokenstr.token = Parser.EOF} as i), _) ->
-        let space_between = i.Tokenstr.space in
-        Printer.add_string printer (Region.lnum last_orig_region) space_between;
+    | Some (({ token = Parser.EOF } as info), _) ->
+        flush_remaining_space info;
         state
 
-    | Some ({ Tokenstr.token = t; region = orig_region; space = space_between; substr }, str) ->
+    | Some (({ token = t;
+               region = orig_region;
+               space = (_space_between_region, space_between);
+               substr } as info), str) ->
 
-        let last_line = Region.lnum last_orig_region in
-        let current_line = Region.lnum orig_region in
-        let new_line = last_line <>  current_line in (* Is this token at a new line? *)
-
-        (* Where the cursor move *)
-        let _cursor_info = match cursor with
-          | None -> None
-          | Some lines_cols ->
-              match
-                Pos.Region.contain_lines_cols last_orig_region lines_cols,
-                Pos.Region.contain_lines_cols orig_region lines_cols
-              with
-              | (`In | `Right), _ -> None (* far past *)
-              | `Left, `Right -> None (* far future *)
-              | `Left, `Left -> (* cursor in the space_between *)
-                  Some `In_space_between 
-              | `Left, `In -> (* cursor on the token *)
-                  Some `In_the_token
-              | _ -> assert false (* It must be more tolerant, but for now... *)
-        in
-
-        match check_lines (Region.lnum orig_region) lines with
-        | `Over -> 
-            (* The token is outside of our interest. 
+        match check_line (Region.lnum orig_region) lines with
+        | `Over ->
+            (* The token is outside of our interest.
                Print the remaining things and go out *)
-            (* Wrong. The line can be over in the previous token,
-               and in this case, we need no space_between printing *) 
-            Printer.add_string printer last_line space_between;
+            flush_remaining_space info;
             state
-        | (`Before | `Inside as line_status) -> 
+        | (`Before | `Inside as line_status) ->
             (*
               Format.eprintf "<%s %d>@."
             *)
 
+            let last_line = Region.lnum last_orig_region in
+            let current_line = Region.lnum orig_region in
+            let at_new_line = last_line <>  current_line in (* Is this token at a new line? *)
+
+            (* update the original indent if [at_new_line] *)
             let state =
-              if new_line then { state with State.orig_indent = Region.columns orig_region } else state
+              if at_new_line then { state with State.orig_indent = Region.columns orig_region }
+              else state
+            in
+
+            (* Where the cursor move *)
+            let _cursor_info = match cursor with
+              | None -> None
+              | Some lines_cols ->
+                  match
+                    Region.contain_lines_cols last_orig_region lines_cols,
+                    Region.contain_lines_cols orig_region lines_cols
+                  with
+                  | (`In | `Right), _ -> None                   (* far past *)
+                  | `Left, `Right     -> None                   (* far future *)
+                  | `Left, `Left      -> Some `In_space_between (* cursor in the space_between *)
+                  | `Left, `In        -> Some `In_the_token     (* cursor on the token *)
+                  | _                 -> assert false           (* It must be more tolerant, but for now... *)
             in
 
             let fix_indent = match line_status with
               | `Over -> assert false
             in
 
-            let pre, post = update_state state new_line fix_indent str orig_region t in
-            
+            let pre, post = Machine.update_state state ~at_new_line ~fix_indent str orig_region t in
+
             (* printing *)
 
-            if new_line then begin
+            if not at_new_line then print_string current_line space_between
+            else begin
               (* the line 1 has no previous new line char *)
               let spaces = try String.sub space_between 0 (String.rindex space_between '\n' + 1) with _ -> "" in
               let indent_string = String.make (State.indent pre) ' ' in
 
-              Printer.add_string printer last_line spaces;
+              (* CR jfuruse: can be a bug. something from space_between_region *)
+              print_string last_line spaces;
 
               if debug then begin
-                Printer.add_string printer current_line indent_string;
+                print_string current_line indent_string;
                 if pre == post then
-                  Printer.add_debug printer current_line
-                    (Printf.sprintf "-- %s\n" (Sexplib.Sexp.to_string_mach (Stack.sexp_of_t pre.State.bases)))
+                  print_debug current_line
+                    (Printf.sprintf "-- %s\n" (Sexp.to_string_mach (Stack.sexp_of_t pre.State.bases)))
                 else
-                  Printer.add_debug printer current_line
+                  print_debug current_line
                     (Printf.sprintf "-- %s // %s\n"
-                      (Sexplib.Sexp.to_string_mach (Stack.sexp_of_t pre.State.bases))
-                      (Sexplib.Sexp.to_string_mach (Stack.sexp_of_t post.State.bases)))
+                      (Sexp.to_string_mach (Stack.sexp_of_t pre.State.bases))
+                      (Sexp.to_string_mach (Stack.sexp_of_t post.State.bases)))
               end;
 
-              Printer.add_string printer current_line indent_string;
-              Printer.add_string printer current_line substr
-            end else begin
-              Printer.add_string printer current_line space_between;
-              Printer.add_string printer current_line substr;
+              print_string current_line indent_string;
             end;
 
+            print_string current_line substr;
+
             (* Now move to the next token *)
-
-            let post =
-              if new_line then
-                { post with
-                  State.last_token = (if t <> Parser.COMMENT then Some t else state.State.last_token)
-                ; last_indent = State.indent pre
-                }
-              else
-                { post with
-                  State.last_token = (if t <> Parser.COMMENT then Some t else state.State.last_token)
-                }
-
+            (* CR jfuruse: last_token thing seems strange. The state machine should be able to
+               access previous tokens freely. (But with risk of memory leak) *)
+            let last_token = if t <> Parser.COMMENT then Some t else state.State.last_token in
+            let post = 
+              { post with 
+                State.last_token = last_token; 
+                last_indent = if at_new_line then State.indent pre else post.State.last_indent }
             in
 
             loop orig_region post str
   if showstate then State.print final_state;
   Tokenstr.close str
 
-let indent_file path = try indent_file path with Exit -> ()
-
 let _ = List.iter indent_file paths
       (lexbuf.Lexing.lex_curr_p.Position.pos_cnum - 
          lexbuf.Lexing.lex_start_p.Position.pos_cnum)
 
-  (* It is not correct! *)
+  (* It is not correct! *) (* CR jfuruse: but how? *)
   let region (_, lexbuf) = lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p
 end
 

File tests/arrow_after_or_pattern.ml

+let rec is_top_let = function
+  | None -> true
+  | Some t ->
+      match t with
+      | COMMENT -> assert false (* COMMENT must be skipped *)
+      | COLON | CLASS | BARRBRACKET
+        -> true
+      | COLON | CLASS | BARRBRACKET
+        -> 
+          true
+      | _ -> 
+          false
+
+let f = fun x y z 
+  -> 3

File tests/semi_in_case.ml

+let rec loop last_orig_region state str = match Tokenstr.destr str with
+  | None -> state
+
+  | Some (({Tokenstr.token = Parser.EOF} as i), _) ->
+      let space_between = i.Tokenstr.space in
+      Printer.add_string printer (Region.lnum last_orig_region) space_between;
+      state
 open Parser
 
 type 'a desc = 
-  | Cons of 'a * 'a t * in_channel
-  | Null
+  | Cons of 'a * 'a t * in_channel option ref
+  | Null of in_channel option ref
 
 and 'a t = 'a desc lazy_t
 
 type 'a info = {
-  space : string;
   token : 'a;
   region : Region.t;
   substr : string;
+  space : Region.t * string;
 }
 
+let close = function
+  | lazy (Null icoptref | Cons (_, _, icoptref)) ->
+      match !icoptref with
+      | None -> ()
+      | Some ic -> icoptref := None; close_in ic 
+
 let of_channel ic = 
+  let icoptref = ref (Some ic) in
   try
     let reader = LexReader.create_from_channel ic in
     let rec loop last_region = 
         try
           LexReader.lex reader Lexer.token 
         with
-        | Lexer.Error (e, loc) ->
+        | Lexer.Error (e, _loc) ->
             Format.eprintf "%a@." Lexer.report_error e;
             assert false
       in
       let region = LexReader.region reader in
+      (* token's string *)
+      let substr = LexReader.current_substring reader in
+
       let space_between = 
         let last_end = (snd last_region).Position.pos_cnum in
         LexReader.substring 
           reader last_end ((fst region).Position.pos_cnum - last_end)
       in
-      (* token's string *)
-      let substr = LexReader.current_substring reader in
-      
-      Cons ({ space = space_between; token; region; substr },
-            lazy (match token with
-            | EOF -> Null
-            | _ -> loop region),
-            ic)
+      let space_between_region = (snd last_region, fst region) in
+
+      Cons ({ token; region; substr; space = space_between_region, space_between },
+            begin match token with
+            | EOF -> 
+                let null = Lazy.lazy_from_val (Null icoptref) in
+                close null;
+                null
+            | _ -> lazy (loop region)
+            end,
+            icoptref)
     in
     lazy (loop Region.zero)
   with
   let ic = open_in path in
   of_channel ic
 
-let close = function
-  | lazy Null -> ()
-  | lazy (Cons (_, _, ic)) -> close_in ic
-
 let destr = function
-  | lazy Null -> None
-  | lazy (Cons (car, cdr, _ic)) -> Some (car, cdr)
+  | lazy Null _ -> None
+  | lazy (Cons (car, cdr, _)) -> Some (car, cdr)

File tokenstr.mli

 type 'a t
 
 type 'a info = {
-  space : string;
   token : 'a;
   region : Pos.Region.t;
   substr : string;
+  space : Pos.Region.t * string
 }
 
 val of_channel : in_channel -> Parser.token info t