works, todo: asynch stuff

Function.hs

@@ -9,6 +9,7 @@ import Language.Haskell.TH.Lift
 import Data.Aeson.TH
 
 data Function = Function { functionName     :: Name
+                         , functionNameRaw  :: String -- for client side prettyness
                          , functionArgTypes :: [SchemaField]
                          , functionRetType  :: SchemaField }
               deriving (Show)

Interface.hs

@@ -33,11 +33,13 @@ genInterface namesR = do
     -- uniqify
     let names = Set.toList . Set.fromList $ namesR
     funs <- mapM genFun names
-    funPairs <- ListE <$> zipWithM (\n f -> [| (n, $(return f)) |]) names funs
+    -- mkName . show NEEDED OTHERWISE WONT BE ABLE TO CALL FROM js!!!
+    funPairs <- ListE <$> zipWithM (\n f -> [| (mkName . show $ n,
+                                                $(return f)) |]) names funs
     internal <- [| \(FunctionCall nam vals) ->
                   let mp = Map.fromList $(return funPairs) in do
                       case Map.lookup nam mp of
-                          Nothing -> liftNowHs $ throwError NoSuchFunction
+                          Nothing -> liftNowHs $ throwError (NoSuchFunction nam)
                           Just f -> f vals
                  |]
     external <- [| runState (sequence $(ListE <$> mapM funSchemaNames names)) Set.empty |]
@@ -59,6 +61,7 @@ funSchemaNames nam = do
               retF = $(return retSchField)
           modify (\s -> foldl (flip Set.insert) s $(ListE <$> anySchemas))
           return $ Function { functionName     = nam
+                            , functionNameRaw  = nameBase nam
                             , functionArgTypes = argFs
                             , functionRetType  = retF }
      |]

NowHs.hs

@@ -7,10 +7,13 @@ import Control.Monad.State
 import Control.Monad.Error
 import Control.Exception
 
+import Language.Haskell.TH
+
+
 import qualified Network.WebSockets as WS
 
 data NowHsError
-    = NoSuchFunction
+    = NoSuchFunction Name
     | IncorrectNumArgs
     | JSONParseError String
     deriving (Show, Typeable)

NowHsPrim.hs

@@ -30,5 +30,8 @@ nowHsM iface sink = do
     forever $ do
         msg <- liftWS WS.receiveData
         case decode' msg of
-            Nothing -> err $ JSONParseError "Cannot parse as FunctionCall"
-            Just fcall -> interfaceInternal iface fcall
+            Nothing -> do
+                err . JSONParseError $ "Cannot parse as FunctionCall: " ++ show msg
+            Just fcall -> do
+                ret <- interfaceInternal iface fcall
+                liftNowHs . liftIO $ WS.sendSink sink . WS.textData $ encode ret

client.js

@@ -0,0 +1,112 @@
+function NowHs (server, port) {
+
+    this.socket = new WebSocket("ws://" + server + ":" + port);
+
+    this.socket.onopen = function () {
+	console.log("Socket opened");
+    };
+
+    var thisRef = this;
+
+    this.socket.onmessage = function (msg) {
+	var msgJSON = JSON.parse(msg.data);
+
+	var functions = msgJSON[0];
+	var schemas = msgJSON[1];
+
+	// set up schemas
+
+	// first put in dummies
+	thisRef.schemas = {};
+	for (var i in schemas) {
+	    thisRef.schemas[schemas[i].schemaName] = {};
+	}
+
+	// now create the schemas
+	for (var i in schemas) {
+
+	    var fields = schemas[i].schemaFields;
+	    var schema = thisRef.schemas[schemas[i].schemaName];
+	    for (var j in fields) {
+		schema[fields[j][0]] = thisRef.createSchemaField (fields[j][1]);
+	    }
+	}
+
+	// now for the functions
+
+	// first set up schemafields for the arguments
+	thisRef.funcSchFields = {}
+	for (var i in functions) {
+	    thisRef.funcSchFields[functions[i].functionName] = []
+	    for (var j in functions[i].functionArgTypes) {
+		thisRef.funcSchFields[functions[i].functionName][j]
+		    = thisRef.createSchemaField (functions[i].functionArgTypes[j]);
+	    }
+	}
+
+	// now set up wrapper functions
+	for (var i in functions) {
+
+	    // using raw name for interface but qualified name internally
+	    thisRef[functions[i].functionNameRaw] = function (fun) { // closure needed
+		return function () {
+
+		    var schemaFields = thisRef.funcSchFields[fun.functionName];
+
+
+		    // check arguments
+		    if (arguments.length - 1 !== schemaFields.length) {
+			throw "Arity mismatch: " + schemaFields.length + " arguments + callback expected";
+		    }
+
+		    for (var arg = 0; arg < arguments.length - 1; arg++) {
+			jsschema.checkField (schemaFields[arg], arguments[arg]);
+		    }
+
+		    var functionCall = {
+			funName : fun.functionName,
+			funArgs : Array.prototype.slice.call (arguments, 0, arguments.length - 1), // retarded javascript
+		    }
+		    var jsn = JSON.stringify (functionCall);
+		    console.log (jsn);
+		    thisRef.socket.send (jsn);
+		    // TODO: FIGURE OUT asynchronous calls (generate hash for each fcall?)
+		}
+	    } (functions[i]);
+	}
+
+	thisRef.socket.onmessage = function (msg) {
+	    console.log ("Yipiieee: " + msg);
+	}
+
+    };
+
+    // returns primitive type or reference to schema
+    this.primOrSchema = function (obj) {
+	switch (obj.type) {
+	case "Prim":
+	    return obj.value;
+	case "SchemaName":
+	    return this.schemas[obj.value];
+	default:
+	    throw ("Cannot happen" + obj.type);
+	}
+    };
+
+    this.createSchemaField = function (schFieldDesc) {
+	switch (schFieldDesc[0]) {
+	case "Required":
+	    return jsschema.required (this.primOrSchema (schFieldDesc[1]));
+	    break;
+	case "Optional":
+	    return jsschema.optional (this.primOrSchema (schFieldDesc[1]));
+	    break;
+	case "Repeated":
+	    return jsschema.repeated (this.primOrSchema (schFieldDesc[1]));
+	    break;
+	default:
+	    throw ("Cannot happen: " + schFieldDesc[0]);
+	}
+    };
+}
+

index.html

@@ -0,0 +1,12 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+  <head>
+    <title>
+
+    </title>
+  </head>
+  <body>
+    <script type="text/javascript" src="client.js"></script>
+    <script type="text/javascript" src="jsschema.js"></script>
+  </body>
+</html>