You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
348 lines
9.1 KiB
348 lines
9.1 KiB
(* 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)) *)
|