Add new packages installed
This commit is contained in:
Mateus Pinto Rodrigues
348
elpa/slime-20180303.1336/contrib/swank-mlworks.sml
Normal file
348
elpa/slime-20180303.1336/contrib/swank-mlworks.sml
Normal file
@@ -0,0 +1,348 @@
|
||||
(* 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)) *)
|
||||
Reference in New Issue
Block a user