Merge pull request #361 from tleedjarv/tuiprofiles

Add profile selection to text UI

src/TODO.txt

@@ -867,7 +867,7 @@ The scroll bar is not usable during transport: every time a line changes
   user to control the colors of all the arrows individually.
 
 Text mode user interface should be brought up to date with graphical
-  interface (it should prompt for profile selection, creation, root
+  interface (it should prompt for profile creation, root
   entry, etc.; command characters should be the same; ...)
 
 Since the manual is pretty big, it would be nice if the on-line version

src/uicommon.ml

@@ -70,7 +70,7 @@ let profileKey =
   Prefs.createString "key" ""
     "!define a keyboard shortcut for this profile (in some UIs)"
     ("Used in a profile to define a numeric key (0-9) that can be used in "
-     ^ "the graphical user interface to switch immediately to this profile.")
+     ^ "the user interface to switch immediately to this profile.")
 (* This preference is not actually referred to in the code anywhere, since
    the keyboard shortcuts are constructed by a separate scan of the preference
    file in uigtk.ml, but it must be present to prevent the preferences module
@@ -492,6 +492,64 @@ let validateAndFixupPrefs () =
 
 (* ---- *)
 
+type profileInfo = {roots:string list; label:string option; key:string option}
+
+let profileKeymap = Array.make 10 None
+
+let provideProfileKey filename k profile info =
+  try
+    let i = int_of_string k in
+    if 0<=i && i<=9 then
+      match profileKeymap.(i) with
+        None -> profileKeymap.(i) <- Some(profile,info)
+      | Some(otherProfile,_) ->
+          raise (Util.Fatal
+            ("Error scanning profile "^
+                System.fspathToPrintString filename ^":\n"
+             ^ "shortcut key "^k^" is already bound to profile "
+             ^ otherProfile))
+    else
+      raise (Util.Fatal
+        ("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
+         ^ "Value of 'key' preference must be a single digit (0-9), "
+         ^ "not " ^ k))
+  with Failure _ -> raise (Util.Fatal
+    ("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
+     ^ "Value of 'key' preference must be a single digit (0-9), "
+     ^ "not " ^ k))
+
+let profilesAndRoots = ref []
+
+let scanProfiles () =
+  Array.iteri (fun i _ -> profileKeymap.(i) <- None) profileKeymap;
+  profilesAndRoots :=
+    (Safelist.map
+       (fun f ->
+          let f = Filename.chop_suffix f ".prf" in
+          let filename = Prefs.profilePathname f in
+          let fileContents = Safelist.map (fun (_, _, n, v) -> (n, v)) (Prefs.readAFile f) in
+          let roots =
+            Safelist.map snd
+              (Safelist.filter (fun (n, _) -> n = "root") fileContents) in
+          let label =
+            try Some(Safelist.assoc "label" fileContents)
+            with Not_found -> None in
+          let key =
+            try Some (Safelist.assoc "key" fileContents)
+            with Not_found -> None in
+          let info = {roots=roots; label=label; key=key} in
+          (* If this profile has a 'key' binding, put it in the keymap *)
+          (try
+             let k = Safelist.assoc "key" fileContents in
+             provideProfileKey filename k f info
+           with Not_found -> ());
+          (f, info))
+       (Safelist.filter (fun name -> not (   Util.startswith name ".#"
+                                          || Util.startswith name Os.tempFilePrefix))
+          (Files.ls Os.unisonDir "*.prf")))
+
+(* ---- *)
+
 let promptForRoots getFirstRoot getSecondRoot =
   (* Ask the user for the roots *)
   let r1 = match getFirstRoot() with None -> exit 0 | Some r -> r in

src/uicommon.mli

@@ -40,6 +40,8 @@ val retry : int Prefs.t
 (* User preference: confirmation before committing merge results *)
 val confirmmerge : bool Prefs.t
 
+val runTestsPrefName : string
+
 (* Format the information about current contents of a path in one replica (the second argument
    is used as a separator) *)
 val details2string : Common.reconItem -> string -> string
@@ -115,3 +117,12 @@ val exitCode: bool * bool -> int
 
 (* Initialization *)
 val testFunction : (unit->unit) ref
+
+(* Profile scanning and selection *)
+type profileInfo = {roots:string list; label:string option; key:string option}
+
+val profileKeymap : (string * profileInfo) option array
+
+val profilesAndRoots : (string * profileInfo) list ref
+
+val scanProfiles : unit -> unit

src/uigtk2.ml

@@ -912,36 +912,6 @@ let termInteract = Some getPassword
 
 (* ------ *)
 
-type profileInfo = {roots:string list; label:string option}
-
-(* ------ *)
-
-let profileKeymap = Array.make 10 None
-
-let provideProfileKey filename k profile info =
-  try
-    let i = int_of_string k in
-    if 0<=i && i<=9 then
-      match profileKeymap.(i) with
-        None -> profileKeymap.(i) <- Some(profile,info)
-      | Some(otherProfile,_) ->
-          raise (Util.Fatal
-            ("Error scanning profile "^
-                System.fspathToPrintString filename ^":\n"
-             ^ "shortcut key "^k^" is already bound to profile "
-             ^ otherProfile))
-    else
-      raise (Util.Fatal
-        ("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
-         ^ "Value of 'key' preference must be a single digit (0-9), "
-         ^ "not " ^ k))
-  with Failure _ -> raise (Util.Fatal
-    ("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
-     ^ "Value of 'key' preference must be a single digit (0-9), "
-     ^ "not " ^ k))
-
-(* ------ *)
-
 module React = struct
   type 'a t = { mutable state : 'a; mutable observers : ('a -> unit) list }
 
@@ -2310,33 +2280,6 @@ TODO:
 
 (* ------ *)
 
-let profilesAndRoots = ref []
-
-let scanProfiles () =
-  Array.iteri (fun i _ -> profileKeymap.(i) <- None) profileKeymap;
-  profilesAndRoots :=
-    (Safelist.map
-       (fun f ->
-          let f = Filename.chop_suffix f ".prf" in
-          let filename = Prefs.profilePathname f in
-          let fileContents = Safelist.map (fun (_, _, n, v) -> (n, v)) (Prefs.readAFile f) in
-          let roots =
-            Safelist.map snd
-              (Safelist.filter (fun (n, _) -> n = "root") fileContents) in
-          let label =
-            try Some(Safelist.assoc "label" fileContents)
-            with Not_found -> None in
-          let info = {roots=roots; label=label} in
-          (* If this profile has a 'key' binding, put it in the keymap *)
-          (try
-             let k = Safelist.assoc "key" fileContents in
-             provideProfileKey filename k f info
-           with Not_found -> ());
-          (f, info))
-       (Safelist.filter (fun name -> not (   Util.startswith name ".#"
-                                          || Util.startswith name Os.tempFilePrefix))
-          (Files.ls Os.unisonDir "*.prf")))
-
 let getProfile quit =
   let ok = ref false in
 
@@ -2417,12 +2360,12 @@ let getProfile quit =
       ~xalign:0. ~selectable:true () in
 
   let fillLst default =
-    scanProfiles();
+    Uicommon.scanProfiles();
     lst_store#clear ();
     Safelist.iter
       (fun (profile, info) ->
          let labeltext =
-           match info.label with None -> "" | Some l -> l in
+           match info.Uicommon.label with None -> "" | Some l -> l in
          let row = lst_store#append () in
          lst_store#set ~row ~column:c_name (Unicode.protect profile);
          lst_store#set ~row ~column:c_label (Unicode.protect labeltext);
@@ -2431,7 +2374,7 @@ let getProfile quit =
            lst#selection#select_iter row;
            lst#scroll_to_cell (lst_store#get_path row) vc_name
          end)
-      (Safelist.sort (fun (p, _) (p', _) -> compare p p') !profilesAndRoots)
+      (Safelist.sort (fun (p, _) (p', _) -> compare p p') !Uicommon.profilesAndRoots)
   in
   let selection = GtkReact.tree_view_selection lst in
   let hasSel = selection >> fun l -> l <> [] in
@@ -2445,7 +2388,7 @@ let getProfile quit =
     (fun info ->
        match info with
          Some ((profile, info), _) ->
-           begin match info.roots with
+           begin match info.Uicommon.roots with
              [r1; r2] -> root1#set_text (Unicode.protect r1);
                          root2#set_text (Unicode.protect r2);
                          tbl#misc#set_sensitive true
@@ -4172,7 +4115,7 @@ lst_store#set ~row ~column:c_path path;
       None -> ()
     | Some(profile, info) ->
         fastProf profile fastKeysyms.(i))
-    profileKeymap;
+    Uicommon.profileKeymap;
 
   ignore (fileMenu#add_separator ());
   ignore (fileMenu#add_item
@@ -4263,7 +4206,7 @@ let start _ =
     ignore_result (tick ());
 
     Os.createUnisonDir();
-    scanProfiles();
+    Uicommon.scanProfiles();
     let detectCmd = createToplevelWindow() in
 
     Uicommon.uiInit

src/uitext.ml

@@ -1177,6 +1177,119 @@ let rec synchronizeUntilDone () =
 
 (* ----------------- Startup ---------------- *)
 
+let profmgrPrefName = "i"
+let profmgrPref =
+  Prefs.createBool profmgrPrefName false ~local:true
+    "interactive profile mode (text UI); command-line only"
+    ("Provide this preference in the command line arguments to enable "
+     ^ "interactive profile manager in the text user interface. Currently "
+     ^ "only profile listing and interactive selection are available. "
+     ^ "Preferences like \\texttt{batch} and \\texttt{silent} remain "
+     ^ "applicable to synchronization functionality.")
+let profmgrUsageMsg = "To start interactive profile selection, type \""
+  ^ Uutil.myName ^ " -" ^ profmgrPrefName ^ "\"."
+
+let addProfileKeys list default =
+  let rec nextAvailKey i =
+    let n = i + 1 in
+    if n >= (Array.length Uicommon.profileKeymap) then
+      n
+    else
+      match Uicommon.profileKeymap.(n) with
+          None   -> n
+        | Some _ -> nextAvailKey n
+  in
+  let keyAndNext (p, info) i =
+    match info.Uicommon.key with
+      Some k -> (k, i)
+    | None   -> if p = default then ("d", i)
+                else ((string_of_int i), (nextAvailKey i))
+  in
+  let rec addKey i acc = function
+  | []           -> []
+  | [prof]       -> let (key, _) = keyAndNext prof i in
+                      (key, prof) :: acc
+  | prof :: rest -> let (key, next) = keyAndNext prof i in
+                      addKey next ((key, prof) :: acc) rest
+  in
+  addKey 0 [] list
+
+let getProfile default =
+  let cmdArgs = Prefs.scanCmdLine Uicommon.shortUsageMsg in
+  Uicommon.scanProfiles ();
+  if Util.StringMap.mem Uicommon.runTestsPrefName cmdArgs ||
+    not (Util.StringMap.mem profmgrPrefName cmdArgs) then
+    Some default
+  else
+  if (List.length !Uicommon.profilesAndRoots) > 10 then begin
+    Trace.log (Format.sprintf "You have too many profiles in %s \
+                for interactive selection. Please specify profile \
+                or roots on command line.\n"
+                (System.fspathToPrintString Os.unisonDir));
+    Trace.log "The profile names are:\n";
+    Safelist.iter (fun (p, _) -> Trace.log (Format.sprintf "  %s\n" p))
+      !Uicommon.profilesAndRoots;
+    Trace.log "\n";
+    Some default
+  end else if (List.length !Uicommon.profilesAndRoots) = 0 then
+    Some default
+  else
+
+  let keyedProfileList = addProfileKeys
+    (Safelist.sort (fun (p, _) (p', _) -> compare p p')
+      !Uicommon.profilesAndRoots)
+    default in
+  let profileList = (Safelist.sort (fun (k, _) (k', _) -> compare k k')
+                      keyedProfileList)
+  in
+
+  (* Must parse command line to get dumbtty and color preferences *)
+  Prefs.parseCmdLine Uicommon.shortUsageMsg;
+  setupTerminal(); setColorPreference ();
+  Prefs.resetToDefaults();
+
+  display "Available profiles:\n key:  profilename         label\n";
+  Safelist.iteri
+    (fun n (key, (profile, info)) ->
+      let labeltext =
+          match info.Uicommon.label with None -> "" | Some l -> l in
+      display (Format.sprintf "  %s%s%s :"
+                (color `Focus) key (color `Reset));
+      display (Format.sprintf "  %s%-18s%s  %s%s%s\n"
+                (color `Focus) profile (color `Reset)
+                (color `Information) labeltext (color `Reset));
+      Safelist.iteri
+          (fun i root -> display (Format.sprintf "         root %i = %s\n"
+                                   (i + 1) root))
+          info.Uicommon.roots
+    )
+    profileList;
+  display "\n";
+
+  let selection = ref (Some default) in
+  let actions = Safelist.append
+    [(["";"n";"/"],
+      "Don't select any profile",
+      (fun () -> selection := None; newLine();
+                   display "\nNo profile selected\n\n"));
+     (["q"],
+      ("exit " ^ Uutil.myName),
+      (fun () -> newLine(); raise Sys.Break))]
+    (Safelist.map (fun (key, (profile, info)) ->
+        ([key],
+        "Profile: " ^ profile,
+        (fun () -> selection := Some profile; newLine();
+                     display ("\nProfile " ^ profile ^ " selected\n\n")))
+      )
+      profileList);
+  in
+  let rec askProfile () =
+    display "Select a profile ";
+    selectAction None actions (fun () -> display "Select a profile ")
+  in
+  askProfile ();
+  !selection
+
 let handleException e =
   restoreTerminal();
   let msg = Uicommon.exn2string e in
@@ -1190,15 +1303,15 @@ let rec start interface =
     (* Just to make sure something is there... *)
     setWarnPrinterForInitialization();
     Uicommon.uiInit
-      (fun s -> Util.msg "%s\n%s\n" Uicommon.shortUsageMsg s; exit 1)
+      (fun s -> Util.msg "%s%s\n\n%s\n" Uicommon.shortUsageMsg profmgrUsageMsg s; exit 1)
       (fun s -> Util.msg "%s" Uicommon.shortUsageMsg; exit 1)
       (fun () -> setWarnPrinter();
                  if Prefs.read silent then Prefs.set Trace.terse true;
                  if not (Prefs.read silent)
                  then Util.msg "%s\n" (Uicommon.contactingServerMsg()))
-      (fun () -> Some "default")
-      (fun () -> Util.msg "%s" Uicommon.shortUsageMsg; exit 1)
-      (fun () -> Util.msg "%s" Uicommon.shortUsageMsg; exit 1)
+      (fun () -> let prof = getProfile "default" in restoreTerminal(); prof)
+      (fun () -> Util.msg "%s%s\n" Uicommon.shortUsageMsg profmgrUsageMsg; exit 1)
+      (fun () -> Util.msg "%s%s\n" Uicommon.shortUsageMsg profmgrUsageMsg; exit 1)
       None;
 
     (* Some preference settings imply others... *)