(* select.sml *)

(* Copyright (C) 2006 Alley Stoughton

   This file is part of crypto, a cryptogram encoder/decoder.  See the
   file COPYING.txt for copying and usage restrictions *)

structure Select :> SELECT =
struct

open CML
structure I = ICCC

(* val strToPropVal : string -> I.prop_val

   convert a string into a property value *)

fun strToPropVal s =
      I.PROP_VAL{typ   = I.atom_STRING,
                 value = I.RAW_DATA{format = I.Raw8,
                                    data   = Byte.stringToBytes s}}

(* val propValToStrOpt : I.prop_val -> string option

   tries to convert a property value into a string, returning NONE, if
   this is impossible, and SOME of the string, if it is possible

   we only apply this function to values of type prop_val that are the
   results of selection requests with targets of STRING; most
   commonly, the typ field will actually be I.atom_STRING, but some
   other type (like COMPOUND_TEXT or C_STRING) may have been supplied;
   for now, we'll just convert the data field into a string, ignoring
   the typ and format fields *)

fun propValToStrOpt(I.PROP_VAL{typ, value = I.RAW_DATA{format, data}}) =
      SOME(Byte.bytesToString data)

(* server commands *)

datatype cmd =
           SetCmd of   (* set the selection *)
             {win        : EXeneBase.window,
              time       : EXeneBase.XTime.time,
              str        : string,
              releaseEvt : unit event}
         | ReleaseCmd  (* release the selection *)

val cmdCh = channel() : cmd chan
val _     = RunCML.logChannel("selection command channel", cmdCh)

(* the server thread has three states: selectIsUnset, acquireSelect
   and selectIsSet *)

(* val selectIsUnSet : cmd event -> 'a *)

fun selectIsUnSet cmdEvt =
      case sync cmdEvt of
           SetCmd{win, time, str, releaseEvt} =>
             acquireSelect(cmdEvt, win, time, str, releaseEvt)
         | Release                            =>
             selectIsUnSet cmdEvt

(* val acquireSelect :
         cmd event * EXeneBase.window * EXeneBase.XTime.time * string *
         unit event ->
         'a *)

and acquireSelect(cmdEvt, win, time, str, clientReleaseEvt) =
      case I.acquireSelection(win, I.atom_PRIMARY, time) of
           NONE         => (sync clientReleaseEvt; selectIsUnSet cmdEvt)
         | SOME selHndl =>
             let val strPropVal = strToPropVal str
             in selectIsSet(cmdEvt, selHndl, strPropVal, clientReleaseEvt) end

(* if the window that owns the current selection is destroyed (without
   having released the section), then we'll still be in this state,
   despite the fact that the server will never send us requests for
   the selection's value or notifications that another window has
   acquired the selection; the downside of this is that we'll only be
   able to tell the original owner that it's lost the selection if and
   when a new command comes in *)

(* val selectIsSet :
         cmd event * ICCC.selection_handle * string * unit event -> 'a *)

and selectIsSet(cmdEvt, selHndl, strPropVal, clientReleaseEvt) =
      select
      [wrap(cmdEvt,
            fn SetCmd{win, time, str, releaseEvt} =>
                 (spawn(fn () => sync clientReleaseEvt);
                  acquireSelect(cmdEvt, win, time, str, releaseEvt))
             | Release                            =>
                 (I.releaseSelection selHndl;
                  spawn(fn () => sync clientReleaseEvt);
                  selectIsUnSet cmdEvt)),
       wrap(I.selectionReqEvt selHndl,
            fn {target, reply, ...} =>
                 (if target = I.atom_STRING
                  then reply(SOME strPropVal)
                  else reply NONE;
                  selectIsSet(cmdEvt, selHndl, strPropVal, clientReleaseEvt))),
       wrap(I.selectionRelEvt selHndl,
            fn () =>
                 (spawn(fn () => sync clientReleaseEvt);
                  selectIsUnSet cmdEvt))]

(* val server : unit -> 'a *)

fun server() = selectIsUnSet(recvEvt cmdCh)

val _ =
      RunCML.logServer("selection server",
                       fn () => ignore(spawn server),
                       fn () => ())

fun set(win, time, str) =
      let val releaseCh : unit chan = channel()
      in send(cmdCh,
              SetCmd{win = win, time = time, str = str,
                     releaseEvt = sendEvt(releaseCh, ())});
         recvEvt releaseCh
      end

fun release() = send(cmdCh, ReleaseCmd)

fun getEvt(win, time) =
      let val auxProp = I.unusedProperty win
      in wrap(I.requestSelection
              {win       = win,
               selection = I.atom_PRIMARY,
               target    = I.atom_STRING,
               property  = I.nameOfProp auxProp, (* used for transferring
                                                    data *)
               time      = time},
              fn propValOpt =>
                   (I.deleteProperty auxProp;
                    case propValOpt of
                         NONE         => NONE
                       | SOME propVal => propValToStrOpt propVal))
      end

val get = sync o getEvt

end;