todo_tag.ml

   1 (* Implement subcommands for listing and adding tags. *)
   2
   3 open CalendarLib
   4
   5 open Todo_types
   6 open Todo_utils
   7 open Todo_tag_utils
   8
   9 open Printf
  10
  11 let cmd_tag_list dbh anon_params =
  12   if anon_params <> [] then
  13     error "extra parameters to 'tag-list' subcommand";
  14
  15   (* Used tags. *)
  16   let rows = PGSQL(dbh) "
  17        select tags.name, tags.colour, tasks.id
  18          from tags_tasks, tags, tasks
  19         where tags_tasks.tagid = tags.id
  20           and tags_tasks.taskid = tasks.id
  21      order by tags.name, tasks.id" in
  22   if rows <> [] then printf "Tags used:\n";
  23   let prev = ref None in
  24   List.iter (
  25     fun (name, colour, taskid) ->
  26       let cur = name, colour in
  27       (match !prev with
  28       | None -> printf "    %s used by" (string_of_tag name colour)
  29       | Some prev when prev <> cur ->
  30          printf "\n    %s used by" (string_of_tag name colour)
  31       | Some _ -> ()
  32       );
  33       prev := Some cur;
  34       printf " #%ld" taskid
  35   ) rows;
  36   if !prev <> None then printf "\n";
  37
  38   (* Unused tags. *)
  39   let rows = PGSQL(dbh) "
  40        select tags.name, tags.colour
  41          from tags
  42         where not exists (select 1 from tags_tasks where tagid = tags.id)
  43      order by tags.name" in
  44   if rows <> [] then printf "Tags not used (delete with 'todo tag-del'):\n";
  45   List.iter (
  46     fun (name, colour) ->
  47       printf "    %s\n" (string_of_tag name colour)
  48   ) rows
  49
  50 let cmd_tag dbh anon_params tag_del =
  51   let id, tag_add =
  52     match anon_params with
  53     | id :: rest -> Int32.of_string id, rest
  54     | _ -> error "incorrect parameters to 'tag' subcommand" in
  55   if anon_params = [] && tag_del = [] then
  56     error "no tags to add or delete from this task";
  57
  58   (* Map the tag_add and tag_del names to tag IDs. *)
  59   let tag_add =
  60     if tag_add <> [] then
  61       PGSQL(dbh) "select id from tags where name in $@tag_add"
  62     else [] in
  63   let tag_del =
  64     if tag_del <> [] then
  65       PGSQL(dbh) "select id from tags where name in $@tag_del"
  66     else [] in
  67
  68   PGOCaml.begin_work dbh;
  69
  70   if tag_del <> [] then
  71     PGSQL(dbh) "delete from tags_tasks
  72                  where taskid = $id and tagid in $@tag_del";
  73
  74   List.iter (
  75     fun tag ->
  76       PGSQL(dbh) "insert into tags_tasks (taskid, tagid)
  77                                   values ($id, $tag)"
  78   ) tag_add;
  79
  80   PGOCaml.commit dbh
  81
  82 let cmd_tag_add dbh anon_params =
  83   let name, colour =
  84     match anon_params with
  85     | [name; colour] -> name, colour
  86     | _ -> error "incorrect parameters to 'tag-add' subcommand" in
  87
  88   PGOCaml.begin_work dbh;
  89
  90   PGSQL(dbh) "insert into tags (name, colour) values ($name, $colour)";
  91
  92   PGOCaml.commit dbh
  93
  94 let cmd_tag_del dbh anon_params =
  95   let name =
  96     match anon_params with
  97     | [name] -> name
  98     | _ -> error "incorrect parameters to 'tag-del' subcommand" in
  99
 100   PGOCaml.begin_work dbh;
 101
 102   PGSQL(dbh) "delete from tags where name = $name";
 103
 104   PGOCaml.commit dbh
 105
 106 let cmd_tag_colour dbh anon_params =
 107   let name, colour =
 108     match anon_params with
 109     | [name; colour] -> name, colour
 110     | _ -> error "incorrect parameters to 'tag-colour' subcommand" in
 111
 112   PGOCaml.begin_work dbh;
 113
 114   PGSQL(dbh) "update tags set colour = $colour where name = $name";
 115
 116   PGOCaml.commit dbh