PoC: Implement Java pure interface with Frege record

frege/compiler/gen/java/MethodCall.fr

@@ -13,6 +13,7 @@ import Compiler.types.Types(unST, Sigma, Tau, TauT, ForAll, RhoTau, RhoFun)
 import Compiler.types.Symbols(SymbolT)
 import Compiler.types.Global
 import Compiler.types.JNames(JName, memberOf)
+import Compiler.types.Strictness()
 
 import Compiler.common.Types as CT
 import Compiler.common.JavaName
@@ -99,6 +100,22 @@ nativeCall g (sym@SymV {nativ = Just item, gargs}) subst aexs = newBind g bsig (
                  [a]   -> JUnop item a
                  _     -> JAtom "null"           -- error was flagged before
              NINew -> JNew jrty args
+             NIExtends ->
+               let evalStG :: Global -> StG a -> a
+                   evalStG g st = fst $ st.run g
+                   x = do g <- getST
+                          si <- symInfo sym
+                          let name  = (head si.argSigs).rho.tau.name
+                              irsym = unJust $ g.findit name
+                              nms = mapMaybe (_.name) [ fld | x@SymD{} <- values irsym.env, fld <- x.flds ]
+                          return $ flip mapMaybe nms $ \fldnm -> do
+                              nativrsym <- g.findit $ si.retSig.rho.tau.name
+                              nativsym <- TreeMap.lookup fldnm nativrsym.env
+                              nativnm <- nativsym.nativ
+                              let nativsi = evalStG g $ symInfo nativsym
+                              fldsym <- TreeMap.lookup fldnm irsym.env
+                              pure $ wrapIRMethod g (head args) (head si.argJTs) nativsi nativnm fldnm fldsym
+               in JNewClass jrty [] (evalStG g x)
              NICast -> case args of
                  [a] -> JInvoke (JAtom item) args    -- was: JCast (Ref (JName "" item) []) a
                  _   -> JAtom "null"
@@ -283,4 +300,39 @@ wildReturn g (symv@SymV{})  = [ v | v@TVar{} ← values (U.freeTauTVars [] TreeM
 wildReturn _ _ = []
 
 
+wrapIRMethod :: Global -> JExpr -> JType -> SymInfo8 -> String -> String -> Symbol -> JDecl
+wrapIRMethod g this irjt nativsi nativnm fldnm fldsym =
+  let nativargs = argDefs attrFinal (nativsi.{ argSigs <- tail, argJTs <- tail }) (getArgs g)
+      fldstri = case fldsym.strsig of
+        Strictness.S xs -> tail xs
+        _               -> []
+      -- how to detect strictness of result value?
+      retstrict = all (_.isStrict) fldstri
+      -- retlazy = if not (null fldstri) then (last fldstri).isStrict else False
+      callit jex = JInvoke { args = [], jex = JExMem { jex, name = "call", targs = [] } }
+      call = if retstrict then id else callit
+  in
+  JMethod
+  { attr = attrs [JPublic]
+  , gvars = []
+  , jtype = nativsi.returnJT
+  , name = nativnm
+  , args = nativargs
+  , body = JBlock $ pure $ JReturn $ call $ invokeIR irjt fldnm this $
+      zipWith (\(_, _, _, x) s -> StriArg x s.isStrict) nativargs fldstri
+  }
 
+data StriArg = StriArg { name :: String, strict :: Bool }
+
+striArgExpr :: StriArg -> JExpr
+striArgExpr (StriArg{name, strict}) =
+  let thunkjt = Ref { jname = JName { qual = "", base = "Thunk" }, gargs = [] }  -- TODO use the proper JType
+      lazy s = JInvoke { args = [JAtom s], jex = JStMem { jt = thunkjt, name = "lazy", targs = [] } }
+  in
+  if strict then JAtom name else lazy name
+
+invokeIR :: JType -> String -> JExpr -> [StriArg] -> JExpr
+invokeIR jt name this args = JInvoke
+  { args = this : map striArgExpr args
+  , jex = JStMem { jt, name, targs = [] }
+  }

frege/compiler/tc/Methods.fr

@@ -61,6 +61,7 @@ import  Compiler.classes.Nice
 --- See Java Language Specification, Section 15. 
 data NIKind = NIOp          --- generate unary or binary expression (JLS 15.15, 15.17 ff.)
             | NINew         --- generate class instance creation expression (JLS 15.9)
+            | NIExtends     --- generate anonymous class declaration (JLS 15.9.5)
             | NIMethod      --- generate instance method invocation expression (JLS 15.12)
             | NIMember      --- generate instance field access expression (JLS 15.11)
             | NICast        --- generate cast expression (JLS 15.16)
@@ -86,6 +87,9 @@ derive Show NIKind
 --- - To get a class instance creation expression, the java item must be @new@
 niKind "new"            = NINew
 
+--- - To get an anonymous class declaration, the java item must be @extends@
+niKind "extends"        = NIExtends
+
 --- - To get an array assignment expression, write "[]="
 niKind "[]="            = NIArraySet
 
@@ -138,6 +142,8 @@ sanity (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, over})
                 E.error (getpos typ) (msgdoc ("Java constructor must have function type"
                     ++ " (did you mean  () -> "
                     ++ nicer rtau g ++ "  ?)"))  
+            NIExtends -> when (nargs < 1) do
+                E.error (getpos typ) (msgdoc ("Java anonymous class declaration must have function type."))
             NIMember -> when (nargs != 1) do
                 E.error (getpos typ) (msgdoc ("Java getter must have one and only one argument - the receiver."))
             NIMethod -> when (nargs < 1) do

sample/.gitignore

@@ -0,0 +1 @@
+/target

sample/J.java

@@ -0,0 +1,8 @@
+public interface J {
+    public int getFoo();
+    public int getBarJava();
+    public boolean getBool();
+
+    public int add(int x, int y);
+    public int add(int x, int y, int z);
+}

sample/Main.fr

@@ -0,0 +1,40 @@
+module Main where
+
+data IR = IR
+  { getFoo :: Int, getBar :: Int, getBool :: Bool
+  , add2 :: Int -> Int -> Int
+  , add3 :: Int -> Int -> Int -> Int
+  }
+
+data J = pure native J where
+  pure native new "extends" :: IR -> J
+  pure native getFoo :: J -> Int
+  pure native getBar getBarJava :: J -> Int
+  pure native getBool :: J -> Bool
+  pure native add2 add :: J -> Int -> Int -> Int
+  pure native add3 add :: J -> Int -> Int -> Int -> Int
+
+-- an alternative way to create a new J
+pure native newJ "extends" :: IR -> J
+
+main = do
+    let j = J.new $ IR
+          { getFoo = 123, getBar = 5, getBool = False
+          , add2 = \x y -> x + y
+          , add3 = \x y z -> x + y + z
+          }
+    println j.getFoo
+    println j.getBar
+    println j.getBool
+    println $ j.add2 3 4
+    println $ j.add3 3 4 5
+    let j = newJ $ IR
+          { getFoo = 15000, getBar = 80, getBool = True
+          , add2 = \x y -> x * y
+          , add3 = \x y z -> x * y * z
+          }
+    println j.getFoo
+    println j.getBar
+    println j.getBool
+    println $ j.add2 3 4
+    println $ j.add3 3 4 5

sample/Makefile

@@ -0,0 +1,17 @@
+all: build/Main.class
+
+clean:
+	$(RM) -r build
+
+run: build/Main.class
+	java -cp ../build:build Main
+
+.PHONY: all clean run
+
+build/Main.class: Main.fr build/J.class
+	mkdir -p build
+	java -cp ../build frege.compiler.Main -d build -ascii Main
+
+build/J.class: J.java
+	mkdir -p build
+	javac -d build J.java