Extending Java classes, implementing interfaces all in Frege without writing Java

HelloWorld.fr

module mmhelloworld.hellofrege.HelloWorld where

import mmhelloworld.hellofrege.Script
import Java.Util (List)

-- Implement Runnable interface
newRunnable :: ST s () -> ST s (Mutable s Runnable)
newRunnable action = jsMethod1ST script "Runnable" "create" action where
  script =
        "var JRunnable = Java.type('java.lang.Runnable'); \n" ++
        "var Runnable = (function() {                     \n" ++
        "  var clz = Java.extend(JRunnable)               \n" ++
        "  var fns = {                                    \n" ++
        "    run: function() {                            \n" ++
        "        this._lambda.apply(1).result().call();   \n" ++
        "    }                                            \n" ++
        "  }                                              \n" ++
        "  return {                                       \n" ++
        "    create: function(lambda) {                   \n" ++
        "      return new clz() {                         \n" ++
        "        _lambda: lambda,                         \n" ++
        "        run: fns.run                             \n" ++
        "      }                                          \n" ++
        "    }                                            \n" ++
        "  }                                              \n" ++
        "})();                                              "

-- Extend java.util.AbstractList with a backed Frege List
fregeListAsJavaList :: [a] -> STMutable s (List a)
fregeListAsJavaList fregeList = jsMethod1ST script "FregeJavaList" "create" fregeList where
  script =
        "var JAbstractListType = Java.type('java.util.AbstractList');                                 \n" ++
        "var PreludeList = Java.type('frege.prelude.PreludeList');                                    \n" ++
        "var FregeJavaList = (function() {                                                            \n" ++
        "  var AbstractList = Java.extend(JAbstractListType)                                          \n" ++
        "  var fns = {                                                                                \n" ++
        "    get: function(index) {                                                                   \n" ++
        "        return PreludeList._excl_excl(this.fregeList, index);                                \n" ++
        "    },                                                                                       \n" ++
        "    size: function() {                                                                       \n" ++
        "        return PreludeList.IListView__lbrack_rbrack.length(this.fregeList);                  \n" ++
        "    }                                                                                        \n" ++
        "  }                                                                                          \n" ++
        "  return {                                                                                   \n" ++
        "    create: function(fregeList) {                                                            \n" ++
        "      return new AbstractList() {                                                            \n" ++
        "        fregeList: fregeList,                                                                \n" ++
        "        get: fns.get,                                                                        \n" ++
        "        size: fns.size                                                                       \n" ++
        "      }                                                                                      \n" ++
        "    }                                                                                        \n" ++
        "  }                                                                                          \n" ++
        "})();                                                                                          "

-- Call a Java function: java.lang.Class.getName()
className :: a -> String
className c = jsFn1 script "className" c where
  script = "function className(a) {  return a.getClass().getName(); }"

main = do
  runnable <- newRunnable $ println "Hello World!"
  jlist <- fregeListAsJavaList [1,2,3,4,5,6]
  element <- jlist.get 3 -- java.util.List.get(index) implemented by `!!` from frege.prelude.PreludeList
  Thread.new runnable >>= _.start
  println element
  println (className jlist)  -- jdk.nashorn.javaadapters.java.util.AbstractList

Script.fr

module mmhelloworld.hellofrege.Script where

import Java.Util (Collection, List, Map, Set, MapEntry)

data ScriptEngine = native javax.script.ScriptEngine where

  pure native argv "javax.script.ScriptEngine.ARGV" :: String
  pure native filename "javax.script.ScriptEngine.FILENAME" :: String
  pure native engine "javax.script.ScriptEngine.ENGINE" :: String
  pure native engine_version "javax.script.ScriptEngine.ENGINE_VERSION" :: String
  pure native name "javax.script.ScriptEngine.NAME" :: String
  pure native language "javax.script.ScriptEngine.LANGUAGE" :: String
  pure native language_version "javax.script.ScriptEngine.LANGUAGE_VERSION" :: String

  native createBindings :: Mutable s ScriptEngine -> STMutable s Bindings

  native eval :: Mutable s ScriptEngine -> String -> Mutable s ScriptContext -> ST s Object throws ScriptException
               | MutableIO ScriptEngine -> MutableIO Reader -> MutableIO Bindings -> IO Object throws ScriptException
               | MutableIO ScriptEngine -> MutableIO Reader -> MutableIO ScriptContext -> IO Object throws ScriptException
               | Mutable s ScriptEngine -> String -> ST s Object throws ScriptException
               | MutableIO ScriptEngine -> MutableIO Reader -> IO Object throws ScriptException
               | Mutable s ScriptEngine -> String -> Mutable s Bindings -> ST s Object throws ScriptException

  native get :: Mutable s ScriptEngine -> String -> ST s Object

  native getBindings :: Mutable s ScriptEngine -> Int -> STMutable s Bindings

  native getContext :: Mutable s ScriptEngine -> STMutable s ScriptContext

  native getFactory :: Mutable s ScriptEngine -> ST s ScriptEngineFactory

  native put :: Mutable s ScriptEngine -> String -> Object -> ST s ()

  native setBindings :: Mutable s ScriptEngine -> Mutable s Bindings -> Int -> ST s ()

  native setContext :: Mutable s ScriptEngine -> Mutable s ScriptContext -> ST s ()

  native asInvocable "(javax.script.Invocable)" :: Mutable s ScriptEngine -> STMutable s Invocable


data Bindings = native javax.script.Bindings where

  native containsKey :: Mutable s Bindings -> Object -> ST s Bool

  native get :: Mutable s Bindings -> Object -> ST s Object

  native put :: Mutable s Bindings -> String -> Object -> ST s Object

  native putAll :: Mutable s Bindings -> Mutable s (Map String Object) -> ST s ()

  native remove :: Mutable s Bindings -> Object -> ST s Object


data Compilable = native javax.script.Compilable where

  native compile :: Mutable s Compilable -> String -> STMutable s CompiledScript throws ScriptException
                  | MutableIO Compilable -> MutableIO Reader -> IOMutable CompiledScript throws ScriptException

data Invocable = native javax.script.Invocable where

  native getInterface :: Mutable s Invocable -> Object -> Class t -> ST s t
                       | Mutable s Invocable -> Class t -> ST s t

  native invokeFunction :: Mutable s Invocable -> String -> ST s result throws ScriptException, NoSuchMethodException
                         | Mutable s Invocable -> String -> a -> ST s result throws ScriptException, NoSuchMethodException
                         | Mutable s Invocable -> String -> a -> b -> ST s result throws ScriptException, NoSuchMethodException
                         | Mutable s Invocable -> String -> a -> b -> c -> ST s result throws ScriptException, NoSuchMethodException
                         | Mutable s Invocable -> String -> a -> b -> c -> d -> ST s result throws ScriptException, NoSuchMethodException
                         | Mutable s Invocable -> String -> a -> b -> c -> d -> e -> ST s result throws ScriptException, NoSuchMethodException

  native invokeMethod :: Mutable s Invocable -> Object -> String -> ST s result throws ScriptException, NoSuchMethodException
                       | Mutable s Invocable -> Object -> String -> a -> ST s result throws ScriptException, NoSuchMethodException
                       | Mutable s Invocable -> Object -> String -> a -> b -> ST s result throws ScriptException, NoSuchMethodException
                       | Mutable s Invocable -> Object -> String -> a -> b -> c -> ST s result throws ScriptException, NoSuchMethodException
                       | Mutable s Invocable -> Object -> String -> a -> b -> c -> d -> ST s result throws ScriptException, NoSuchMethodException
                       | Mutable s Invocable -> Object -> String -> a -> b -> c -> d -> e -> ST s result throws ScriptException, NoSuchMethodException
                       | Mutable s Invocable -> Object -> String -> a -> b -> c -> d -> e -> f -> ST s result throws ScriptException, NoSuchMethodException
                       | Mutable s Invocable -> Object -> String -> a -> b -> c -> d -> e -> f -> g -> ST s result throws ScriptException, NoSuchMethodException
                       | Mutable s Invocable -> Object -> String -> a -> b -> c -> d -> e -> f -> g -> h -> ST s result throws ScriptException, NoSuchMethodException


data ScriptContext = native javax.script.ScriptContext where

  pure native engine_scope "javax.script.ScriptContext.ENGINE_SCOPE" :: Int
  pure native global_scope "javax.script.ScriptContext.GLOBAL_SCOPE" :: Int

  native getAttribute :: Mutable s ScriptContext -> String -> Int -> ST s Object
                       | Mutable s ScriptContext -> String -> ST s Object

  native getAttributesScope :: Mutable s ScriptContext -> String -> ST s Int

  native getBindings :: Mutable s ScriptContext -> Int -> STMutable s Bindings

  native getErrorWriter :: MutableIO ScriptContext -> IOMutable Writer

  native getReader :: MutableIO ScriptContext -> IOMutable Reader

  native getScopes :: Mutable s ScriptContext -> STMutable s (List Integer)

  native getWriter :: MutableIO ScriptContext -> IOMutable Writer

  native removeAttribute :: Mutable s ScriptContext -> String -> Int -> ST s Object

  native setAttribute :: Mutable s ScriptContext -> String -> Object -> Int -> ST s ()

  native setBindings :: Mutable s ScriptContext -> Mutable s Bindings -> Int -> ST s ()

  native setErrorWriter :: MutableIO ScriptContext -> MutableIO Writer -> IO ()

  native setReader :: MutableIO ScriptContext -> MutableIO Reader -> IO ()

  native setWriter :: MutableIO ScriptContext -> MutableIO Writer -> IO ()

data ScriptEngineFactory = pure native javax.script.ScriptEngineFactory where

  pure native getEngineName :: ScriptEngineFactory -> String

  pure native getEngineVersion :: ScriptEngineFactory -> String

  native getExtensions :: ScriptEngineFactory -> STMutable s (List String)

  pure native getLanguageName :: ScriptEngineFactory -> String

  pure native getLanguageVersion :: ScriptEngineFactory -> String

  native getMethodCallSyntax :: ScriptEngineFactory -> String -> String -> Mutable s (JArray String) -> ST s String

  native getMimeTypes :: ScriptEngineFactory -> STMutable s (List String)

  native getNames :: ScriptEngineFactory -> STMutable s (List String)

  pure native getOutputStatement :: ScriptEngineFactory -> String -> String

  pure native getParameter :: ScriptEngineFactory -> String -> Object

  native getProgram :: ScriptEngineFactory -> Mutable s (JArray String) -> ST s String

  native getScriptEngine :: ScriptEngineFactory -> STMutable s ScriptEngine

data AbstractScriptEngine = native javax.script.AbstractScriptEngine where

  native eval :: MutableIO AbstractScriptEngine -> MutableIO Reader -> MutableIO Bindings -> IO Object throws ScriptException
               | Mutable s AbstractScriptEngine -> String -> Mutable s Bindings -> ST s Object throws ScriptException
               | Mutable s AbstractScriptEngine -> String -> ST s Object throws ScriptException
               | MutableIO AbstractScriptEngine -> MutableIO Reader -> IO Object throws ScriptException

  native get :: Mutable s AbstractScriptEngine -> String -> ST s Object

  native getBindings :: Mutable s AbstractScriptEngine -> Int -> STMutable s Bindings

  native getContext :: Mutable s AbstractScriptEngine -> STMutable s ScriptContext

  native put :: Mutable s AbstractScriptEngine -> String -> Object -> ST s ()

  native setBindings :: Mutable s AbstractScriptEngine -> Mutable s Bindings -> Int -> ST s ()

  native setContext :: Mutable s AbstractScriptEngine -> Mutable s ScriptContext -> ST s ()

data CompiledScript = native javax.script.CompiledScript where

  native eval :: Mutable s CompiledScript -> ST s Object throws ScriptException
               | Mutable s CompiledScript -> Mutable s Bindings -> ST s Object throws ScriptException
               | Mutable s CompiledScript -> Mutable s ScriptContext -> ST s Object throws ScriptException

  native getEngine :: Mutable s CompiledScript -> STMutable s ScriptEngine


data ScriptEngineManager = native javax.script.ScriptEngineManager where

  native new :: ClassLoader -> IOMutable ScriptEngineManager
              | () -> STMutable s ScriptEngineManager

  native get :: Mutable s ScriptEngineManager -> String -> ST s Object

  native getBindings :: Mutable s ScriptEngineManager -> STMutable s Bindings

  native getEngineByExtension :: Mutable s ScriptEngineManager -> String -> STMutable s ScriptEngine

  native getEngineByMimeType :: Mutable s ScriptEngineManager -> String -> STMutable s ScriptEngine

  native getEngineByName :: Mutable s ScriptEngineManager -> String -> STMutable s ScriptEngine

  native getEngineFactories :: Mutable s ScriptEngineManager -> STMutable s (List ScriptEngineFactory)

  native put :: Mutable s ScriptEngineManager -> String -> Object -> ST s ()

  native registerEngineExtension :: Mutable s ScriptEngineManager -> String -> ScriptEngineFactory -> ST s ()

  native registerEngineMimeType :: Mutable s ScriptEngineManager -> String -> ScriptEngineFactory -> ST s ()

  native registerEngineName :: Mutable s ScriptEngineManager -> String -> ScriptEngineFactory -> ST s ()

  native setBindings :: Mutable s ScriptEngineManager -> Mutable s Bindings -> ST s ()

data SimpleBindings = native javax.script.SimpleBindings where

  native new :: Mutable s (Map String Object) -> STMutable s SimpleBindings
              | () -> STMutable s SimpleBindings

  native clear :: Mutable s SimpleBindings -> ST s ()

  native containsKey :: Mutable s SimpleBindings -> Object -> ST s Bool

  native containsValue :: Mutable s SimpleBindings -> Object -> ST s Bool

  native entrySet :: Mutable s SimpleBindings -> STMutable s (Set (MapEntry String Object))

  native get :: Mutable s SimpleBindings -> Object -> ST s Object

  native isEmpty :: Mutable s SimpleBindings -> ST s Bool

  native keySet :: Mutable s SimpleBindings -> STMutable s (Set String)

  native put :: Mutable s SimpleBindings -> String -> Object -> ST s Object

  native putAll :: Mutable s SimpleBindings -> Mutable s (Map String Object) -> ST s ()

  native remove :: Mutable s SimpleBindings -> Object -> ST s Object

  native size :: Mutable s SimpleBindings -> ST s Int

  native values :: Mutable s SimpleBindings -> STMutable s (Collection Object)

data SimpleScriptContext = native javax.script.SimpleScriptContext where

  native new :: () -> STMutable s SimpleScriptContext

  native getAttribute :: Mutable s SimpleScriptContext -> String -> ST s Object
                       | Mutable s SimpleScriptContext -> String -> Int -> ST s Object

  native getAttributesScope :: Mutable s SimpleScriptContext -> String -> ST s Int

  native getBindings :: Mutable s SimpleScriptContext -> Int -> STMutable s Bindings

  native getErrorWriter :: MutableIO SimpleScriptContext -> IOMutable Writer

  native getReader :: MutableIO SimpleScriptContext -> IOMutable Reader

  native getScopes :: Mutable s SimpleScriptContext -> STMutable s (List Integer)

  native getWriter :: MutableIO SimpleScriptContext -> IOMutable Writer

  native removeAttribute :: Mutable s SimpleScriptContext -> String -> Int -> ST s Object

  native setAttribute :: Mutable s SimpleScriptContext -> String -> Object -> Int -> ST s ()

  native setBindings :: Mutable s SimpleScriptContext -> Mutable s Bindings -> Int -> ST s ()

  native setErrorWriter :: MutableIO SimpleScriptContext -> MutableIO Writer -> IO ()

  native setReader :: MutableIO SimpleScriptContext -> MutableIO Reader -> IO ()

  native setWriter :: MutableIO SimpleScriptContext -> MutableIO Writer -> IO ()


data ScriptException = pure native javax.script.ScriptException where

  pure native new :: String -> ScriptException
                   | String -> String -> Int -> Int -> ScriptException
                   | String -> String -> Int -> ScriptException
                   | Exception -> ScriptException

  pure native getColumnNumber :: ScriptException -> Int

  pure native getFileName :: ScriptException -> String

  pure native getLineNumber :: ScriptException -> Int

  pure native getMessage :: ScriptException -> String

derive Exceptional ScriptException

data NoSuchMethodException = pure native java.lang.NoSuchMethodException where

  pure native new :: () -> NoSuchMethodException
                   | String -> NoSuchMethodException

derive Exceptional NoSuchMethodException

newJs :: STMutable s ScriptEngine
newJs = ScriptEngineManager.new () >>= _.getEngineByName "nashorn"

jsMethod1 :: String -> String -> String -> arg -> result
jsMethod1 script clazz method arg1 = ST.run r where
  r :: ST s a
  r = jsMethod1ST script clazz method arg1

jsMethod1ST :: String -> String -> String -> arg -> ST s result
jsMethod1ST script clazz method arg1 = do
  js <- newJs
  jsInvoker <- js.asInvocable
  js.eval script
  clz <- js.eval clazz
  jsInvoker.invokeMethod clz method arg1

jsFn1 :: String -> String -> arg -> result
jsFn1 script f arg1 = ST.run r where
  r :: ST s a
  r = do
        js <- newJs
        jsInvoker <- js.asInvocable
        js.eval script
        jsInvoker.invokeFunction f arg1

jsFn2 :: String -> String -> arg1 -> arg2 -> result
jsFn2 script f arg1 arg2 = ST.run r where
  r :: ST s a
  r = do
        js <- newJs
        jsInvoker <- js.asInvocable
        js.eval script
        jsInvoker.invokeFunction f arg1 arg2