dotfiles/emacs/.emacs.d/elpa/slime-20190724.1352/contrib/swank-mlworks.sml

(* swank-mlworks.sml -- SWANK server for MLWorks
 *
 * This code has been placed in the Public Domain.
 *)

(* This is an experiment to see how the interfaces/modules would look
 * in a language with a supposedly "good" module system.
 *
 * MLWorks is probably the only SML implementation that tries to
 * support "interactive programming".  Since MLWorks wasn't maintained
 * the last 15 or so years, big chunks of the SML Basis Library are
 * missing or not the way as required by the standard.  That makes it
 * rather hard to do anything; it also shows that MLWorks hasn't been
 * "used in anger" for a long time.
 *)

structure Swank = struct

    structure Util = struct
	fun utf8ToString (v:Word8Vector.vector) : string = Byte.bytesToString v
	fun stringToUtf8 s = Byte.stringToBytes s
      end

    structure Map = struct
	datatype ('a, 'b) map = Alist of {list: ('a * 'b) list ref,
					  eq: ('a * 'a) -> bool}

	fun stringMap () =
	    Alist {list = ref [],
		   eq = (fn (x:string,y:string) => x = y)}


	fun lookup (Alist {list, eq}, key) =
	    let fun search [] = NONE
		  | search ((key', value) :: xs) =
		    if eq (key', key) then SOME value
		    else search xs
	    in search (!list)
	    end

	fun put (Alist {list, eq}, key, value) =
	    let val l = (key, value) :: (!list)
	    in list := l
	    end

      end

    structure CharBuffer = struct
	local
	    structure C = CharArray
	    datatype buffer = B of {array : C.array ref,
				    index: int ref}
	in

	fun new hint = B {array = ref (C.array (hint, #"\000")),
			  index = ref 0}

	fun append (buffer as B {array, index}, char) =
	    let val a = !array
		val i = !index
		val len = C.length a
	    in if i < len then
		   (C.update (a, i, char);
		    index := i + 1;
		    ())
	       else let val aa = C.array (2 * len, #"\000")
			fun copy (src, dst) =
			    let val len = C.length src
				fun loop i =
				    if i = len then ()
				    else (C.update (dst, i, C.sub (src, i));
					  loop (i + 1))
			    in loop 0 end
		    in copy (a, aa);
		       C.update (aa, i, char);
		       array := aa;
		       index := i + 1;
		       ()
		    end
	    end

	fun toString (B {array, index}) =
	    let val a = !array
		val i = !index
	    in CharVector.tabulate (i, fn i => C.sub (a, i)) end

	end

      end


    structure Sexp = struct
	structure Type = struct
	    datatype sexp = Int of int
			  | Str of string
			  | Lst of sexp list
			  | Sym of string
			  | QSym of string * string
			  | T
			  | Nil
			  | Quote
	  end
	open Type

	exception ReadError

	fun fromUtf8 v =
	    let val len = Word8Vector.length v
		val index = ref 0
		fun getc () =
		    case getc' () of
			SOME c => c
		     |  NONE => raise ReadError
		and getc' () =
		    let val i = !index
		    in if i = len then NONE
		       else (index := i + 1;
			     SOME (Byte.byteToChar (Word8Vector.sub (v, i))))
		    end
		and ungetc () = index := !index - 1
		and sexp () : sexp =
		    case getc () of
			#"\"" => string (CharBuffer.new 100)
		      | #"("  => lst ()
		      | #"'" => Lst [Quote, sexp ()]
		      | _ => (ungetc(); token ())
		and string buf : sexp =
		    case getc () of
			#"\"" => Str (CharBuffer.toString buf)
		      | #"\\" => (CharBuffer.append (buf, getc ()); string buf)
		      | c => (CharBuffer.append (buf, c); string buf)
		and lst () =
		    let val x = sexp ()
		    in case getc () of
			   #")" => Lst [x]
			 | #" " => let val Lst y = lst () in Lst (x :: y) end
			 | _ => raise ReadError
		    end
		and token () =
		    let val tok = token' (CharBuffer.new 50)
			val c0 = String.sub (tok, 0)
		    in if Char.isDigit c0 then (case Int.fromString tok of
						    SOME i => Int i
						  | NONE => raise ReadError)
		       else
			   Sym (tok)
		    end
		and token' buf : string =
		    case getc' () of
			NONE => CharBuffer.toString buf
		      | SOME #"\\" => (CharBuffer.append (buf, getc ());
				       token' buf)
		      | SOME #" " => (ungetc (); CharBuffer.toString buf)
		      | SOME #")" => (ungetc (); CharBuffer.toString buf)
		      | SOME c => (CharBuffer.append (buf, c); token' buf)
	    in
		sexp ()
	    end

	fun toString sexp =
	    case sexp of
		(Str s) => "\"" ^ String.toCString s ^ "\""
	      | (Lst []) => "nil"
	      | (Lst xs) => "(" ^ String.concatWith " " (map toString xs) ^ ")"
	      | Sym (name) => name
	      | QSym (pkg, name) => pkg ^ ":" ^ name
	      | Quote => "quote"
	      | T => "t"
	      | Nil => "nil"
	      | Int i => Int.toString i

	fun toUtf8 sexp = Util.stringToUtf8 (toString sexp)
      end

    structure Net = struct
	local
	    structure S = Socket
	    structure I = INetSock
	    structure W = Word8Vector

	    fun createSocket (port) =
		let val sock : S.passive I.stream_sock = I.TCP.socket ()
		    val SOME localhost = NetHostDB.fromString "127.0.0.1"
		in
		    S.Ctl.setREUSEADDR (sock, true);
		    S.bind (sock, I.toAddr (localhost, port));
		    S.listen (sock, 2);
		    sock
		end

	    fun addrToString sockAddr =
		let val (ip, port) = I.fromAddr sockAddr
		in NetHostDB.toString ip ^ ":" ^ Int.toString port
		end

	    exception ShortRead of W.vector
	    exception InvalidHexString of string
	in

	fun acceptConnection port =
	    let val sock = createSocket port
		val addr = S.Ctl.getSockName sock
		val _ = print ("Listening on: " ^ addrToString addr ^ "\n")
		val (peer, addr) = S.accept sock
	    in
		S.close sock;
		print ("Connection from: " ^ addrToString addr ^ "\n");
		peer
	    end

	fun receivePacket socket =
	    let val v = S.recvVec (socket, 6)
		val _ = if W.length v = 6 then ()
			else raise ShortRead v
		val s = Util.utf8ToString v
		val _ = print ("s = " ^ s ^ "\n")
		val len =
		    case StringCvt.scanString (Int.scan StringCvt.HEX) s of
			SOME len => len
		      | NONE => raise InvalidHexString s
		val _ = print ("len = " ^ Int.toString len ^ "\n")
		val payload = S.recvVec (socket, len)
		val plen = W.length payload
		val _ = print ("plen = " ^ Int.toString plen ^ "\n")
		val _ = if plen = len then ()
			else raise ShortRead payload
	    in
		payload
	    end

	fun nibbleToHex i:string = Int.fmt StringCvt.HEX i

	fun loadNibble i pos =
	    Word32.toInt (Word32.andb (Word32.>> (Word32.fromInt i,
						  Word.fromInt (pos * 4)),
				       0wxf))

	fun hexDigit i pos = nibbleToHex (loadNibble i pos)

	fun lenToHex i =
	    concat [hexDigit i 5,
		    hexDigit i 4,
		    hexDigit i 3,
		    hexDigit i 2,
		    hexDigit i 1,
		    hexDigit i 0]

	fun sendPacket (payload:W.vector, socket) =
	    let val len = W.length payload
		val header = Util.stringToUtf8 (lenToHex len)
		val packet = W.concat [header, payload]
	    in  print ("len = " ^ Int.toString len ^ "\n"
		       ^ "header = " ^ lenToHex len ^ "\n"
		       ^ "paylad = " ^ Util.utf8ToString payload ^ "\n");
		S.sendVec (socket, {buf = packet, i = 0, sz = NONE})
	    end

	end
      end

    structure Rpc = struct
	open Sexp.Type

	val funTable : (string, sexp list -> sexp) Map.map
	    = Map.stringMap ()

	fun define name f = Map.put (funTable, name, f)

	exception UnknownFunction of string
	fun call (name, args) =
	    (print ("call: " ^ name ^ "\n");
	     case Map.lookup (funTable, name) of
		 SOME f => f args
	       | NONE => raise UnknownFunction name)


	local fun getpid () =
	    Word32.toInt (Posix.Process.pidToWord (Posix.ProcEnv.getpid ()))
	in
	fun connectionInfo [] =
	    Lst [Sym ":pid", Int (getpid ()),
		 Sym ":lisp-implementation", Lst [Sym ":type", Str "MLWorks",
						  Sym ":name", Str "mlworks",
						  Sym ":version", Str "2.x"],
		 Sym ":machine", Lst [Sym ":instance", Str "",
				      Sym ":type", Str "",
				      Sym ":version", Str ""],
		 Sym ":features", Nil,
		 Sym ":package", Lst [Sym ":name", Str "root",
				      Sym ":prompt", Str "-"]]
	end

	fun nyi _ = Nil

	local structure D = Shell.Dynamic
	in
	fun interactiveEval [Str string] =
	    let val x = D.eval string
	    in Str (concat [D.printValue x, " : ", D.printType (D.getType x)])
	    end
	end

	val _ =
	    (define "swank:connection-info" connectionInfo;
	     define "swank:swank-require" nyi;
	     define "swank:interactive-eval" interactiveEval;
	     ())
      end

    structure EventLoop = struct
	open Sexp.Type

	fun execute (sexp, pkg) =
	    (print ("sexp = " ^ (Sexp.toString sexp) ^ "\n");
	     case sexp of
		 Lst (Sym name :: args) => Rpc.call (name, args))

	fun emacsRex (sexp, pkg, id as Int _, sock) =
	    let val result = (Lst [Sym (":ok"), execute (sexp, pkg)]
			      handle exn => (Lst [Sym ":abort",
						  Str (exnName exn ^ ": "
						       ^ exnMessage exn)]))
		val reply = Lst [Sym ":return", result, id]
	    in Net.sendPacket (Sexp.toUtf8 reply, sock)
	    end

	fun dispatch (Lst ((Sym key) :: args), sock) =
	    case key of
		":emacs-rex" => let val  [sexp, pkg, _, id] = args
				in emacsRex (sexp, pkg, id, sock)
				end

	fun processRequests socket:unit =
	    let val sexp = Sexp.fromUtf8 (Net.receivePacket socket)
	    in print ("request: "
		      ^ Util.utf8ToString (Sexp.toUtf8 sexp)
		      ^ "\n");
	       dispatch (sexp, socket);
	       processRequests socket
	    end

      end

    (* val _ = EventLoop.processRequests (Net.acceptConnection 4005) *)
    val _ = ()
  end

(* (Swank.EventLoop.processRequests (Swank.Net.acceptConnection 4005)) *)