diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,37 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/). +## Next + +### Added +### Removed +### Changed + +## [0.10.0] - 2020-11-30 + +### Changed + +* Support building with jni-0.8 + +## [0.9.1] - 2020-07-16 + +### Changed + +* Fix Tweag logo image in readme + +## [0.9.0] - 2020-07-16 + +### Added + +* Added support for ghc-8.10.1 and ghc-8.11 (HEAD) +* Use TH.addCorePlugin instead of -fplugin +* An interface based on linear types (https://github.com/tweag/inline-java/pull/127) +* An abstract monad to use in the safe interfaces (https://github.com/tweag/inline-java/pull/128) + +### Removed + +* Removed support for ghc < 8.10.1 + ## [0.8.4] - 2018-07-11 ### Changed diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,7 @@ # inline-java: Call any JVM function from Haskell [![CircleCI](https://circleci.com/gh/tweag/inline-java.svg?style=svg)](https://circleci.com/gh/tweag/inline-java) - -**NOTE 1: you'll need GHC >= 8.0.2 to compile and use this package.** +[![Build status](https://badge.buildkite.com/143d77b1eec06bb865d694dbe685f2ed7712caa12852c8808e.svg?branch=master)](https://buildkite.com/tweag-1/inline-java) The Haskell standard includes a native foreign function interface (FFI). Using it can be a bit involved and only C support is @@ -26,7 +25,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fplugin=Language.Java.Inline.Plugin #-} module Main where import Data.Text (Text) @@ -44,12 +42,9 @@ ## Building it **Requirements:** -* the [Stack][stack] build tool (version 1.2 or above); +* the [Stack][stack] build tool; * either, the [Nix][nix] package manager, -* or, OpenJDK and Gradle installed from your distro. - -On OS X, you'll need to install the [Legacy Java SE 6][osx-java-se] -runtime when prompted, even when using Nix. +* or, OpenJDK installed from your distro. To build: @@ -76,8 +71,43 @@ [stack]: https://github.com/commercialhaskell/stack [stack-nix]: https://docs.haskellstack.org/en/stable/nix_integration/#configuration [nix]: http://nixos.org/nix -[osx-java-se]: https://support.apple.com/kb/dl1572?locale=fr_FR +## Building the safe interface + +There is [an experimental interface][safe-inline-java] which catches +common memory management mistakes at compile time. This interface +currently needs a [fork][linear-types-ghc] of GHC which supports the +[LinearTypes][linear-types-proposal] language extension. Both the GHC +fork and the safe interface can be built with: + +``` +$ stack --nix --stack-yaml stack-linear.yaml build inline-java +``` + +For examples of how to use the safe interface you can check +the [directory server][directory-server] or the +[wizzardo-http benchmark][wizzardo-http-benchmark]. + + +[directory-server]: examples/directory-server +[linear-types-ghc]: https://github.com/tweag/ghc/tree/linear-types#ghc-branch-with-linear-types +[linear-types-proposal]: https://github.com/tweag/ghc-proposals/blob/linear-types2/proposals/0000-linear-types.rst +[safe-inline-java]: https://github.com/tweag/inline-java/blob/master/src/linear-types/Language/Java/Inline/Safe.hs +[wizzardo-http-benchmark]: benchmarks/wizzardo-http + +## Further reading + +Check the [tutorial][inline-java-tutorial] on how to use `inline-java`. +If you want to know more about how it is implemented, look at +[our post][inline-java-plugin] on the plugin implementation. + +There is also a post which gives an overview of the +[safe interface][safe-interface-post]. + +[inline-java-tutorial]: https://www.tweag.io/posts/2017-09-15-inline-java-tutorial.html +[inline-java-plugin]: https://www.tweag.io/posts/2017-09-22-inline-java-ghc-plugin.html +[safe-interface-post]: https://www.tweag.io/blog/2020-02-06-safe-inline-java + ## Debugging The generated java output can be dumped to stderr by passing to GHC @@ -88,6 +118,76 @@ If `-ddump-to-file` is in effect (as when using `stack`), the java code is dumped to `.dump-java` instead. +## Troubleshooting + +### Build-time error `package or class Blah does not exist` + +`inline-java` is going to invoke the `javac` compiler, and any classes +used in `java` quotations need to be reachable via the `CLASSPATH` +environment variable. For instance, +``` +CLASSPATH=/path/to/my.jar:/some/other/path ghc --make program.hs +``` + +### Run-time error `ThreadNotAttached` + +Haskell threads need to be attached to the JVM before making JNI calls. +`Foreign.JNI.withJVM` attaches the calling thread, and other threads +can be attached with `Foreign.JNI.runInAttachedThread`. When the JVM +calls into Haskell, the thread is already attached. + +### Run-time error `ThreadNotBound` + +JNI calls need to be done from bound threads. The thread invoking the +`main` function of a program is bound. Threads created with `forkOS` +are bound. In other threads, `Control.Concurrent.runInBoundThread` +can be used to run a computation in a bound thread. + +### Run-time error `java.lang.NoClassDefFoundError` + +Classes might not be found at runtime if they are not in a folder or +jar listed in the parameter `-Djava.class.path=` passed +to `withJVM`. + +```Haskell +withJVM ["-Djava.class.path=/path/to/my.jar:/some/other/path"] $ do + ... +``` + +Additionally, classes might not be found if a thread other than the one +calling `main` is trying to use them. One solution is to have the thread +calling `main` load all the classes in advance. Then the classes will +be available in the JVM for other threads that need them. +Calling `Language.Java.Inline.loadJavaWrappers` will have the effect of +loading all classes needed for `java` quotations, which will suffice in +many cases. + +Another option is to set the context class loader of other threads, +so they earn the ability to load classes on their own. This might +work when the thread was attached to the JVM via the JNI, and +the context class loader is just `null`. + +```Haskell +loader <- [java| Thread.currentThread().getContextClassLoader() |] +... +forkOS $ runInAttachedThread $ do + [java| { Thread.currentThread().setContextClassLoader($loader); } |] + ... +``` + +### Run-time error `JVMException` + +Any java exception that goes from Java to Haskell will be wrapped +as a value of type `JVMException` with a reference to the Java object +representing the exception. The message and the stack trace of the +exception can be retrieved from the exception object with more JNI +calls, e.g. + +```Haskell +\(JVMException e) -> [java| { $e.printStackTrace(); } |] +``` +or with `JNI.Foreign.showException`. + ## License Copyright (c) 2015-2016 EURL Tweag. @@ -100,7 +200,7 @@ ## Sponsors          -[](http://tweag.io) +[![Tweag I/O](http://i.imgur.com/0HK8X4y.png)](http://tweag.io)              [![LeapYear](http://i.imgur.com/t9VxRHn.png)](http://leapyear.io) diff --git a/benchmarks/micro/Main.hs b/benchmarks/micro/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/micro/Main.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Control.DeepSeq (NFData(..)) +import Criterion.Main as Criterion +import Control.Monad (void) +import qualified Data.Coerce as Coerce +import Data.Int +import Data.Singletons (SomeSing(..)) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import qualified Foreign.JNI as JNI +import qualified Foreign.JNI.Types as JNI +import Foreign.Ptr +import GHC.Stable +import Language.Java +import Language.Java.Inline + +newtype Box a = Box { unBox :: a } + +-- Not much sense in deepseq'ing foreign pointers. But needed for call to 'env' +-- below. +instance NFData (Box a) where rnf (Box a) = seq a () + +benchCallbacks :: Benchmark +benchCallbacks = + env ini $ \ ~(Box (fun, obj, jstr, jstr2, jstr3, jstr4)) -> + bgroup "Callbacks" + [ bgroup "inline-java" + [ bench "return-x100" $ withLocalFrame 1 $ + void @_ @JObject [java| { + String s = null; + for(int i=0;i<100;++i) { + s = ((java.util.function.BiFunction) $fun).apply($jstr, $jstr2); }; + return s.concat($jstr); + } |] + , bench "no-callback" $ withLocalFrame 1 $ + void @_ @JObject [java| { if ($jstr3 == null){}; return $jstr.concat($jstr2); } |] + , bench "no-callback-4-args" $ withLocalFrame 1 $ + void @_ @JObject [java| { if ($jstr3 == $jstr4){}; return $jstr.concat($jstr2); } |] + , bench "loadJavaWrappers" $ nfIO $ loadJavaWrappers + ] + , bgroup "jvm" + [ bench "return" $ withLocalFrame 1 $ + void @_ @JObject $ call fun "apply" obj (JNI.upcast jstr) + , bench "no-callback" $ withLocalFrame 1 $ + void @_ @JString $ call jstr "concat" jstr2 + ] + ] + where + ini = do + loadJavaWrappers + Box <$> ((,,,,,) + <$> newCallbackFunction (const . return) + <*> ([java| new Object() |] :: IO JObject) + <*> ([java| "Hello, " |] :: IO JString) + <*> ([java| "World!" |] :: IO JString) + <*> ([java| "Hello again, " |] :: IO JString) + <*> ([java| "The World." |] :: IO JString) + ) + withLocalFrame refsPerRun action = + perBatchEnvWithCleanup + (JNI.pushLocalFrame . (refsPerRun*) . fromIntegral) + (\_ _ -> void (JNI.popLocalFrame jnull)) $ + \() -> action + +type JNIFun = JNIEnv -> Ptr JObject -> Ptr JObject -> Ptr JObject -> IO (Ptr JObject) + +foreign import ccall "wrapper" wrapObjectFun + :: JNIFun -> IO (FunPtr JNIFun) + +-- Export only to get a FunPtr. +foreign export ccall "inline_java_callbacks_benchmark_freeIterator" freeIterator + :: JNIEnv -> Ptr JObject -> Int64 -> IO () +foreign import ccall "&inline_java_callbacks_benchmark_freeIterator" freeIteratorPtr + :: FunPtr (JNIEnv -> Ptr JObject -> Int64 -> IO ()) + +data FunPtrTable = FunPtrTable + { callbackPtr :: FunPtr JNIFun + } + +freeIterator :: JNIEnv -> Ptr JObject -> Int64 -> IO () +freeIterator _ _ ptr = do + let sptr = castPtrToStablePtr $ intPtrToPtr $ fromIntegral ptr + FunPtrTable{..} <- deRefStablePtr sptr + freeHaskellFunPtr callbackPtr + freeStablePtr sptr + +-- | Reflects a stream with no batching. +newCallbackFunction + :: (JObject -> JObject -> IO JObject) + -> IO (J ('Iface "java.util.function.BiFunction")) +newCallbackFunction f = do + callbackPtr <- wrapObjectFun $ \_ _jthis jarg1 jarg2 -> + unsafeForeignPtrToPtr <$> Coerce.coerce <$> do + a1 <- JNI.objectFromPtr jarg1 + a2 <- JNI.objectFromPtr jarg2 + f a1 a2 + -- Keep FunPtr's in a table that can be referenced from the Java side, so + -- that they can be freed. + tblPtr :: Int64 <- fromIntegral . ptrToIntPtr . castStablePtrToPtr <$> newStablePtr FunPtrTable{..} + fun <- + [java| new java.util.function.BiFunction() { + @Override + public native Object apply(Object o1, Object o2); + + private native void hsFinalize(long tblPtr); + + @Override + public void finalize() { hsFinalize($tblPtr); } + } |] + klass <- JNI.getObjectClass fun >>= JNI.newGlobalRef + JNI.registerNatives klass + [ JNI.JNINativeMethod + "apply" + (methodSignature + [ SomeSing (sing :: Sing ('Class "java.lang.Object")) + , SomeSing (sing :: Sing ('Class "java.lang.Object")) + ] + (sing :: Sing ('Class "java.lang.Object"))) + callbackPtr + , JNI.JNINativeMethod + "hsFinalize" + (methodSignature [SomeSing (sing :: Sing ('Prim "long"))] (sing :: Sing 'Void)) + freeIteratorPtr + ] + return fun + + +main :: IO () +main = withJVM [] $ do + Criterion.defaultMain + [ benchCallbacks ] diff --git a/inline-java.cabal b/inline-java.cabal --- a/inline-java.cabal +++ b/inline-java.cabal @@ -1,5 +1,5 @@ name: inline-java -version: 0.8.4 +version: 0.10.0 synopsis: Java interop via inline Java code in Haskell modules. description: Please see README.md. homepage: http://github.com/tweag/inline-java#readme @@ -21,8 +21,16 @@ type: git location: https://github.com/tweag/inline-java +flag linear-types + description: Build the linear types interface. + default: False + library - hs-source-dirs: src + hs-source-dirs: src/common + if impl(ghc >= 8.11) + hs-source-dirs: src/ghc-8.11 + else + hs-source-dirs: src/ghc-8.10 c-sources: cbits/bctable.c cc-options: -std=c99 -Wall -Werror include-dirs: cbits/ @@ -31,19 +39,25 @@ exposed-modules: Language.Java.Inline Language.Java.Inline.Cabal + Language.Java.Inline.Internal + Language.Java.Inline.Internal.Magic + Language.Java.Inline.Internal.QQMarker + Language.Java.Inline.Internal.QQMarker.Names Language.Java.Inline.Plugin + Language.Java.Inline.Unsafe other-modules: - Language.Java.Inline.Magic + GhcPlugins.Extras + FastString.Extras build-depends: -- Can't build at all with GHC < 8.0.2. - base >4.9.0.0 && <5, + base >=4.14.0.0 && <5, bytestring >=0.10, Cabal >=1.24.2, directory >=1.2, filepath >=1, - ghc >=8.0.2 && <8.5, - jni >=0.4 && <0.7, - jvm >=0.4 && <0.5, + ghc >=8.10.1 && <=8.11, + jni >=0.8 && <0.9, + jvm >=0.6 && <0.7, language-java >=0.2, mtl >=2.2.1, process >=1.2, @@ -51,13 +65,23 @@ template-haskell >=2.10, temporary >=1.2 default-language: Haskell2010 + if flag(linear-types) + hs-source-dirs: src/linear-types + exposed-modules: + Language.Java.Inline.Safe + Language.Java.Inline.Internal.QQMarker.Safe + build-depends: + linear-base ==0.1.0.0 + else + hs-source-dirs: src/no-linear-types test-suite spec type: exitcode-stdio-1.0 - hs-source-dirs: tests + hs-source-dirs: tests/common main-is: Main.hs other-modules: + SafeSpec Spec Language.Java.InlineSpec build-depends: @@ -66,5 +90,33 @@ jvm, hspec, inline-java, - text + QuickCheck, + quickcheck-unicode, + text, + vector default-language: Haskell2010 + ghc-options: -threaded + cpp-options: -DHSPEC_DISCOVER=hspec-discover + if flag(linear-types) + hs-source-dirs: tests/linear-types + other-modules: + Language.Java.Inline.SafeSpec + build-depends: + linear-base ==0.1.0.0 + else + hs-source-dirs: tests/no-linear-types + +benchmark micro-benchmarks + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: benchmarks/micro + build-depends: + base >=4.8 && <5, + criterion, + deepseq >=1.4.2, + inline-java, + jni, + jvm, + singletons + default-language: Haskell2010 + ghc-options: -threaded diff --git a/src/Language/Java/Inline.hs b/src/Language/Java/Inline.hs deleted file mode 100644 --- a/src/Language/Java/Inline.hs +++ /dev/null @@ -1,206 +0,0 @@ --- | = Inline Java quasiquotation --- --- See the --- --- for an introduction to quasiquotation. The quasiquoter exported in this --- module allows embedding arbitrary Java expressions and blocks of statements --- inside Haskell code. You can call any Java method and define arbitrary inline --- code using Java syntax. No FFI required. --- --- Here is the same example as in "Language.Java", but with inline Java calls: --- --- @ --- {-\# LANGUAGE DataKinds \#-} --- {-\# LANGUAGE QuasiQuotes \#-} --- {-\# OPTIONS_GHC -fplugin=Language.Java.Inline.Plugin \#-} --- module Object where --- --- import Language.Java as J --- import Language.Java.Inline --- --- newtype Object = Object ('J' (''Class' "java.lang.Object")) --- instance 'Coercible' Object --- --- clone :: Object -> IO Object --- clone obj = [java| $obj.clone() |] --- --- equals :: Object -> Object -> IO Bool --- equals obj1 obj2 = [java| $obj1.equals($obj2) |] --- --- ... --- @ - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module Language.Java.Inline - ( java - , imports - , loadJavaWrappers - ) where - -import Data.Data -import Data.List (isPrefixOf, intercalate, isSuffixOf, nub) -import Data.String (fromString) -import Foreign.JNI (defineClass) -import Language.Java -import Language.Java.Inline.Magic -import qualified Language.Java.Lexer as Java -import Language.Haskell.TH.Quote -import qualified Language.Haskell.TH as TH -import qualified Language.Haskell.TH.Syntax as TH -import Language.Haskell.TH (Q) -import System.IO.Unsafe (unsafePerformIO) - --- Implementation strategy --- --- We know we'll need to declare a new wrapper (a Java static method), but we --- don't know the types of the arguments nor the return type. So we first name --- this method and generate a Haskell call to it at the quasiquotation site. --- Then, we inject a call to 'qqMarker' which carries the needed types to the --- plugin phase. --- --- The plugin phase is implemented in Language.Java.Inline.Plugin. In this phase --- we make a pass over the module Core to find all the occurrences of --- 'qqMarker'. By this point the types of all the variables in the local scope --- that was captured are fully determined. So we can analyze these types to --- determine what the signature of the wrapper should be, in order to declare --- it. --- --- The last step is to ask the Java toolchain to produce .class bytecode from --- our declarations. We embed this bytecode in the binary, adding a reference to --- it in a global bytecode table. That way at runtime we can enumerate --- the bytecode blobs, and load them into the JVM one by one. - --- | Java code quasiquoter. Example: --- --- @ --- {-# OPTIONS_GHC -fplugin=Language.Java.Inline.Plugin #-} --- imports "javax.swing.JOptionPane" --- --- hello :: IO () --- hello = do --- message <- reflect ("Hello World!" :: Text) --- [java| JOptionPane.showMessageDialog(null, $message) |] --- @ --- --- A quasiquote is a snippet of Java code. The code is assumed to be a block --- (sequence of statements) if the first non whitespace character is a @{@ --- (curly brace) character. Otherwise it's parsed as an expression. Variables --- with an initial @$@ (dollar) sign are allowed. They have a special meaning: --- they stand for antiqotation variables (think of them as format specifiers in --- printf format string). An antiquotation variable @$foo@ is well-scoped if --- there exists a variable with the name @foo@ in the Haskell context of the --- quasiquote, whose type is 'Coercible' to a Java primitive or reference type. --- -java :: QuasiQuoter -java = QuasiQuoter - { quoteExp = \txt -> blockOrExpQQ txt - , quotePat = error "Language.Java.Inline: quotePat" - , quoteType = error "Language.Java.Inline: quoteType" - , quoteDec = error "Language.Java.Inline: quoteDec" - } - --- | Private newtype to key the TH state. -newtype IJState = IJState { methodCount :: Integer } - -initialIJState :: IJState -initialIJState = IJState 0 - -getIJState :: Q IJState -getIJState = TH.getQ >>= \case - Nothing -> do - TH.putQ initialIJState - return initialIJState - Just st -> return st - -setIJState :: IJState -> Q () -setIJState = TH.putQ - --- | Declares /import/ statements to be included in the java compilation unit. --- e.g. --- --- > imports "java.util.*" --- -imports :: String -> Q [TH.Dec] -imports imp = do - tJI <- [t| JavaImport |] - lineNumber <- fromIntegral . fst . TH.loc_start <$> TH.location - expJI <- TH.lift (JavaImport imp lineNumber) - TH.addTopDecls - -- {-# ANN module (JavaImport imp :: JavaImport) #-} - [ TH.PragmaD $ TH.AnnP TH.ModuleAnnotation (TH.SigE expJI tJI) ] - return [] - --- | Yields the next method index. A different index is produced per call. -nextMethodIdx :: Q Integer -nextMethodIdx = do - ij <- getIJState - setIJState $ ij { methodCount = methodCount ij + 1 } - return $ methodCount ij - --- | Idempotent action that loads all wrappers in every module of the current --- program into the JVM. You shouldn't need to call this yourself. -loadJavaWrappers :: IO () -loadJavaWrappers = doit `seq` return () - where - {-# NOINLINE doit #-} - doit = unsafePerformIO $ push $ do - loader :: J ('Class "java.lang.ClassLoader") <- do - thr <- callStatic "java.lang.Thread" "currentThread" [] - call (thr :: J ('Class "java.lang.Thread")) "getContextClassLoader" [] - forEachDotClass $ \DotClass{..} -> do - _ <- defineClass (referenceTypeName (SClass className)) loader classBytecode - return () - pop - -mangle :: TH.Module -> String -mangle (TH.Module (TH.PkgName pkgname) (TH.ModName mname)) = - mangleClassName pkgname mname - -blockOrExpQQ :: String -> Q TH.Exp -blockOrExpQQ txt@(words -> toks) -- ignore whitespace - | ["{"] `isPrefixOf` toks - , ["}"] `isSuffixOf` toks = blockQQ txt - | otherwise = expQQ txt - -expQQ :: String -> Q TH.Exp -expQQ input = blockQQ $ "{ return " ++ input ++ "; }" - -blockQQ :: String -> Q TH.Exp -blockQQ input = do - idx <- nextMethodIdx - let mname = "inline__method_" ++ show idx - vnames = nub - [ n | Java.L _ (Java.IdentTok ('$' : n)) <- Java.lexer input ] - thnames = map TH.mkName vnames - - -- Return a call to the static method we just generated. - let args = [ [| coerce $(TH.varE name) |] | name <- thnames ] - thismod <- TH.thisModule - lineNumber <- fromIntegral . fst . TH.loc_start <$> TH.location - [| loadJavaWrappers >> - qqMarker - (Proxy :: Proxy $(TH.litT $ TH.strTyLit input)) - (Proxy :: Proxy $(TH.litT $ TH.strTyLit mname)) - (Proxy :: Proxy $(TH.litT $ TH.strTyLit $ intercalate "," vnames)) - (Proxy :: Proxy $(TH.litT $ TH.numTyLit $ lineNumber)) - $(return $ foldr (\a b -> TH.TupE [TH.VarE a, b]) (TH.TupE []) thnames) - Proxy - (callStatic - (fromString $(TH.stringE ("io.tweag.inlinejava." ++ mangle thismod))) - (fromString $(TH.stringE mname)) - $(TH.listE args)) |] diff --git a/src/Language/Java/Inline/Cabal.hs b/src/Language/Java/Inline/Cabal.hs deleted file mode 100644 --- a/src/Language/Java/Inline/Cabal.hs +++ /dev/null @@ -1,141 +0,0 @@ --- | This module contains Cabal @Setup.hs@ hooks to set the @CLASSPATH@ to use --- when compiling inline code. The @CLASSPATH@ environment variable specifies --- where to find JVM package dependencies, such as third party packages --- downloaded from . --- --- You can set the @CLASSPATH@ manually, or extract one from an external build --- system configuration. Currently supported build systems: --- --- * - -module Language.Java.Inline.Cabal - ( gradleHooks - , prependClasspathWithGradle - , gradleBuild - , addJarsToClasspath - ) where - -import Control.Exception (evaluate) -import Control.Monad (when) -import Data.Monoid -import Data.List (intersperse, isPrefixOf) -import Distribution.Simple -import Distribution.Simple.Setup (BuildFlags) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) -import Distribution.PackageDescription -import System.Directory (doesFileExist, getCurrentDirectory) -import System.Environment (lookupEnv, setEnv) -import System.FilePath -import System.IO -import System.IO.Temp (withSystemTempFile) -import System.Process (callProcess, readProcess) - --- | Adds the 'prependClasspathWithGradle' and 'gradleBuild' hooks. --- --- Also adds the jar produced by gradle to the data-files. -gradleHooks :: UserHooks -> UserHooks -gradleHooks hooks = hooks - { preBuild = prependClasspathWithGradle <> preBuild hooks - , buildHook = gradleBuild <> buildHook hooks - , preHaddock = prependClasspathWithGradle <> preHaddock hooks - , instHook = instHook simpleUserHooks . addJarToDataFiles - , copyHook = copyHook simpleUserHooks . addJarToDataFiles - , regHook = regHook simpleUserHooks . addJarToDataFiles - } - --- | Prepends the given jar paths to the CLASSPATH. -addJarsToClasspath :: [FilePath] -> UserHooks -> UserHooks -addJarsToClasspath extraJars hooks = hooks - { preBuild = setClasspath extraJars <> preBuild hooks - , preHaddock = setClasspath extraJars <> preHaddock hooks - } - -gradleBuildFile :: FilePath -gradleBuildFile = "build.gradle" - -findGradleBuild :: FilePath -> IO (Maybe FilePath) -findGradleBuild cwd = do - let path = cwd gradleBuildFile - yes <- doesFileExist path - if yes then return (Just path) else return Nothing - --- | Set the @CLASSPATH@ from a Gradle build configuration. Uses the classpath --- for the @main@ source set. -getGradleClasspath :: FilePath -> IO String -getGradleClasspath parentBuildfile = do - withSystemTempFile "build.gradle" $ \buildfile h -> do - hClose h - writeFile buildfile $ - unlines - [ "apply from: '" ++ parentBuildfile ++ "'" - , "task classpath { doLast { println sourceSets.main.compileClasspath.getAsPath() } }" - ] - readProcess "gradle" ["-q", "-b", buildfile, "classpath"] "" - -- Get the last line of output. Sometimes Gradle prepends garbage to the - -- output despite the -q flag. - >>= return . last . lines - --- | Prepends the @CLASSPATH@ with the classpath from a Gradle build --- configuration. -prependClasspathWithGradle :: Args -> b -> IO HookedBuildInfo -prependClasspathWithGradle _ _ = do - here <- getCurrentDirectory - origclasspath <- lookupEnv "CLASSPATH" - mbbuildfile <- findGradleBuild here - case mbbuildfile of - Nothing -> fail $ unwords [gradleBuildFile, "file not found in", here] - Just buildfile -> do - classpath <- getGradleClasspath buildfile - setEnv "CLASSPATH" $ classpath ++ maybe "" (':':) origclasspath - return (Nothing, []) - -setClasspath :: [FilePath] -> a -> b -> IO HookedBuildInfo -setClasspath extraJars _ _ = do - mclasspath <- lookupEnv "CLASSPATH" - setEnv "CLASSPATH" $ - concat $ intersperse ":" $ - maybe extraJars (\c -> extraJars ++ [c]) mclasspath - return (Nothing, []) - --- | Call @gradle build@ as part of the Cabal build. Useful to e.g. build --- auxiliary Java source code and to create packages. -gradleBuild :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () -gradleBuild pd _ _ _ = do - setProjectName - callProcess "gradle" ["build"] - where - settingsFile = "settings.gradle" - - setProjectName :: IO () - setProjectName = do - missingProjectName <- isProjectNameMissing - when missingProjectName $ - appendFile "settings.gradle" $ - "\nrootProject.name = '" ++ - unPackageName (pkgName (package pd)) ++ "'\n" - - isProjectNameMissing :: IO Bool - isProjectNameMissing = do - exists <- doesFileExist settingsFile - if not exists - then return True - else withFile settingsFile ReadMode $ \h -> do - b <- all (not . ("rootProject.name =" `isPrefixOf`)) . lines - <$> hGetContents h - -- If we don't evaluate the boolean before returning, the - -- file handle will be closed when we try to read the file. - evaluate b - --- ".jar" is a file build by gradle during building. This file needs --- to be installed together with the library, otherwise it wouldn't be available --- to build other code depending on it. Therefore, we add the jar to the field --- dataFiles in the hooks instHook, copyHook and regHook. This way the jar is --- installed, but cabal does not account it when deciding if the package needs --- to be rebuilt. - -addJarToDataFiles :: PackageDescription -> PackageDescription -addJarToDataFiles pd = pd - { dataFiles = - ("build/libs" unPackageName (pkgName (package pd)) <.> "jar") - : dataFiles pd - } diff --git a/src/Language/Java/Inline/Magic.hsc b/src/Language/Java/Inline/Magic.hsc deleted file mode 100644 --- a/src/Language/Java/Inline/Magic.hsc +++ /dev/null @@ -1,115 +0,0 @@ --- | Internal module defining some magic, kept separate from the rest, that --- depends on compiler internals. - -{-# LANGUAGE CApiFFI #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} - -module Language.Java.Inline.Magic - ( DotClass(..) - , JavaImport(..) - , forEachDotClass - , mangleClassName - , qqMarker - ) where - -import Control.Monad (forM_) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Unsafe as BS -import Data.Char (isAlphaNum) -import Data.Data -import Foreign.C.String (peekCString) -import Foreign.C.Types (CSize) -import Foreign.Ptr (Ptr, nullPtr, plusPtr) -import Foreign.Storable -import GHC.Stack (HasCallStack, withFrozenCallStack) -import GHC.TypeLits (Nat, Symbol) -import qualified Language.Haskell.TH.Syntax as TH -import Language.Java (Coercible, Ty) - -#include "bctable.h" - --- | The bytecode corresponding to a java class -data DotClass = DotClass - { className :: String - , classBytecode :: ByteString - } - -data JavaImport = JavaImport String Integer - deriving (Typeable, Data, TH.Lift) - --- | Produces a Java class name from a package and a module name. -mangleClassName :: String -> String -> String -mangleClassName pkgname modname = concat - [ "Inline__" - , filter isAlphaNum pkgname - , "_" - , map (\case '.' -> '_'; x -> x) modname - ] - -foreign import capi unsafe "&inline_java_bctable" bctable :: Ptr (Ptr DotClass) - -peekDotClass :: Ptr DotClass -> IO DotClass -peekDotClass ptr = do - sz <- #{peek struct inline_java_dot_class, bytecode_sz} ptr - bc <- #{peek struct inline_java_dot_class, bytecode} ptr - DotClass - <$> (#{peek struct inline_java_dot_class, name} ptr >>= peekCString) - <*> (BS.unsafePackCStringLen (bc, fromIntegral (sz :: CSize))) - --- | Runs the given function for every class in the bytecode table. -forEachDotClass :: (DotClass -> IO ()) -> IO () -forEachDotClass f = peek bctable >>= go - where - go :: Ptr DotClass -> IO () - go tbl - | tbl == nullPtr = return () - | otherwise = do - dcs_ptr <- #{peek struct inline_java_pack, classes} tbl - tbl_sz <- #{peek struct inline_java_pack, size} tbl - forM_ [0..(tbl_sz-1)] $ \i -> do - let dc_sz = #{size struct inline_java_dot_class} - f =<< peekDotClass (dcs_ptr `plusPtr` (i * dc_sz)) - #{peek struct inline_java_pack, next} tbl >>= go - --- | A function to mark the occurrence of java quasiquotations -qqMarker - :: forall - -- k -- the kind variable shows up in Core - (args_tys :: k) -- JType's of arguments - tyres -- JType of result - (input :: Symbol) -- input string of the quasiquoter - (mname :: Symbol) -- name of the method to generate - (antiqs :: Symbol) -- antiquoted variables as a comma-separated list - (line :: Nat) -- line number of the quasiquotation - args_tuple -- uncoerced argument types - b. -- uncoerced result type - (tyres ~ Ty b, Coercibles args_tuple args_tys, Coercible b, HasCallStack) - => Proxy input - -> Proxy mname - -> Proxy antiqs - -> Proxy line - -> args_tuple - -> Proxy args_tys - -> IO b - -> IO b -qqMarker _ _ _ _ _ = withFrozenCallStack $ - error $ - "Please pass -fplugin=Language.Java.Inline.Plugin" - ++ " to ghc when building this module." - -class Coercibles xs (tys :: k) | xs -> tys -instance Coercibles () () -instance (ty ~ Ty x, Coercible x, Coercibles xs tys) => Coercibles (x, xs) '(ty, tys) diff --git a/src/Language/Java/Inline/Plugin.hs b/src/Language/Java/Inline/Plugin.hs deleted file mode 100644 --- a/src/Language/Java/Inline/Plugin.hs +++ /dev/null @@ -1,489 +0,0 @@ --- | This plugin generates Java bytecode from modules using the java --- QuasiQuoter and inserts it in a global bytecode table from where the --- it is loaded at runtime. -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -module Language.Java.Inline.Plugin (plugin) where - -import Control.Monad.Writer hiding ((<>)) -import Convert (thRdrNameGuesses) -import qualified Data.ByteString as BS -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as Builder -import Data.Char (chr, ord) -import Data.Data (Data) -import Data.List (intersperse, isSuffixOf) -import Data.Maybe (mapMaybe) -import Data.Monoid (Endo(..)) -import Data.IORef (readIORef) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import ErrUtils (ghcExit) -import FamInstEnv (normaliseType) -import Foreign.JNI.Types (JType(..)) -import GhcPlugins -import IfaceEnv (lookupOrigNameCache) -import qualified Language.Haskell.TH as TH -import qualified Language.Haskell.TH.Syntax as TH -import Language.Java.Inline.Magic -#if MIN_VERSION_ghc(8, 2, 1) -import NameCache (nsNames) -#endif -#if MIN_VERSION_ghc(8, 4, 0) -import Prelude hiding ((<>)) -#endif -import TyCoRep -import TysWiredIn (nilDataConName, consDataConName) -import System.Directory (listDirectory) -import System.FilePath ((), (<.>), takeDirectory) -import System.IO (withFile, IOMode(WriteMode), hPutStrLn, stderr) -import System.IO.Temp (withSystemTempDirectory) -import System.Process (callProcess) - --- The 'java' quasiquoter produces annotations of type 'JavaImport', and it also --- inserts calls in the code to the function 'qqMarker'. --- --- 'qqMarker' carries many bits of information that are useful in generating the --- QQ code. --- --- This plugin first makes a pass to collect the 'qqMarker' calls in the module --- (collectQQMarkers). --- Then it generates the java stubs from the information in the found --- occurrences (buildJava). --- Finally, it calls the java compiler to produce the bytecode and --- arranges it to be inserted it in the bytecode table in constructor functions --- (cConstructors). - -plugin :: Plugin -plugin = defaultPlugin - { installCoreToDos = install - } - where - install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] - install args todo = do -#if !MIN_VERSION_ghc(8,2,1) - reinitializeGlobals -#endif - return (CoreDoPluginPass "inline-java" (qqPass args) : todo) - - qqPass :: [CommandLineOption] -> ModGuts -> CoreM ModGuts - qqPass args guts = do - findTHName 'qqMarker >>= \case - -- If qqMarker cannot be found we assume the module does not use - -- inline-java. - Nothing -> return guts - Just qqMarkerName -> do - (binds, qqOccs) <- collectQQMarkers qqMarkerName (mg_binds guts) - let jimports = getModuleAnnotations guts :: [JavaImport] - dcs <- buildJava guts qqOccs jimports - >>= maybeDumpJava args - >>= buildBytecode - return guts - { mg_binds = binds - , mg_foreign = appendStubC (mg_foreign guts) $ - text bctable_header - $$ dotClasses dcs - $$ cConstructors - } - - -- The contents of bctable.h - -- - -- #include "bctable.h" wouldn't work when ghc is used from the - -- command line without saying -package inline-java. - bctable_header :: String - bctable_header = $(do - loc <- TH.location - let root = iterate takeDirectory (TH.loc_filename loc) !! 5 - f = root "cbits/bctable.h" - TH.addDependentFile f - TH.lift =<< TH.runIO (readFile f) - ) - -- Dumps the java code to stderr or a file, depending on the set flags. - maybeDumpJava :: [CommandLineOption] -> Builder -> CoreM Builder - maybeDumpJava args b - | elem "dump-java" args = do - dflags <- getDynFlags - if gopt Opt_DumpToFile dflags then do - thisModule <- getModule - let fname = moduleNameString (moduleName thisModule) ++ ".dump-java" - path = maybe fname ( fname) (dumpDir dflags) - liftIO $ withFile path WriteMode $ \h -> Builder.hPutBuilder h b - else liftIO $ do - hPutStrLn stderr "=== inline-java (dump-java) BEGIN ===" - Builder.hPutBuilder stderr b - hPutStrLn stderr "=== inline-java (dump-java) END ===" - return b - maybeDumpJava _ b = return b - --- | Produces a Java compilation unit from the quasiquotation occurrences and --- the java imports. --- --- The compilation unit looks like: --- --- > package io.tweag.inlinejava; --- > import java.util.*; // .hs:25 --- > --- > public final class Inline___ { --- > public static java.lang.Object method_0() --- > { return 1 + 1 ; } // .hs:31 --- > public static java.lang.Object inline__method_1() --- > { // .hs:34 --- > int x = 1; // .hs:34 --- > int y = 2; // .hs:34 --- > return x + y; // .hs:34 --- > } // .hs:34 --- > public static java.lang.Object inline__method_2(final int $x) --- > { return $x + 1 ; } // .hs:42 --- > public static java.lang.Object inline__method_3() --- > { return new Object() {} ; } // .hs:46 --- > } --- --- Where @inline_method_i@ is the method corresponding to the @ith@ --- quasiquotation. -buildJava :: ModGuts -> [QQOcc] -> [JavaImport] -> CoreM Builder -buildJava guts qqOccs jimports = do - let importsJava = mconcat - [ mconcat [ "import ", Builder.stringUtf8 jimp - , "; // .hs:", Builder.integerDec n - , "\n" - ] - | JavaImport jimp n <- jimports - ] - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - methods <- forM qqOccs $ \QQOcc {..} -> do - let (_, normty) = normaliseType fam_envs Nominal (expandTypeSynonyms qqOccResTy) - jTypeNames <- findJTypeNames - resty <- case toJavaType jTypeNames normty of - Just resty -> return resty - Nothing -> failWith $ hsep - [ parens (text "line" <+> integer qqOccLineNumber) <> ":" - , text "The result type of the quasiquotation" - , quotes (ppr qqOccResTy) - , text "is not sufficiently instantiated to infer a java type." - ] - let argnames = BS.split (fromIntegral $ fromEnum ',') qqOccAntiQs - argtys <- zipWithM (getArg jTypeNames qqOccLineNumber) - argnames qqOccArgTys - return $ mconcat - [ "public static " - , Builder.byteString resty - , " " - , Builder.byteString qqOccMName - , "(" - , mconcat $ intersperse "," argtys - , ") throws Throwable // .hs:" - , Builder.integerDec qqOccLineNumber - , "\n" - , adjustInput qqOccLineNumber qqOccInput - ] - thisModule <- getModule - let className = mangle thisModule - return $ mconcat - [ "package io.tweag.inlinejava;\n" - , importsJava - , "\n" - , "public final class " - , Builder.stringUtf8 className - , " {\n" - , mconcat methods - , "}\n" - ] - where - getArg :: JTypeNames -> Integer -> BS.ByteString -> Type -> CoreM Builder - getArg jTypeNames _ name - (expandTypeSynonyms -> toJavaType jTypeNames -> Just jtype) = - return $ mconcat - ["final ", Builder.byteString jtype, " $", Builder.byteString name] - getArg _ line name t = failWith $ hsep - [ parens (text "line" <+> integer line) <> ":" - , quotes (ftext (mkFastStringByteString name) <+> "::" <+> ppr t) - , text "is not sufficiently instantiated to infer a java type." - ] - - adjustInput :: Integer -> BS.ByteString -> Builder - adjustInput lineNumber bs = - let txt = Text.strip $ Text.decodeUtf8 bs - block = if Text.isPrefixOf "{" txt && Text.isSuffixOf "}" txt - then Text.lines txt - else Text.lines $ Text.concat ["{ return ", txt, "}" ] - - in Builder.byteString $ Text.encodeUtf8 $ Text.unlines - [ Text.concat [ln, " // .hs:", Text.pack (show lineNumber)] - | ln <- block - ] - --- | Produces a class name from a Module. -mangle :: Module -> String -mangle m = mangleClassName (unitIdString (moduleUnitId m)) - (moduleNameString (moduleName m)) - --- Call the java compiler and feeds it the given Java code in Builder form. -buildBytecode :: Builder -> CoreM [DotClass] -buildBytecode unit = do - m <- getModule - liftIO $ withSystemTempDirectory "inlinejava" $ \dir -> do - let src = dir mangle m <.> "java" - withFile src WriteMode $ \h -> Builder.hPutBuilder h unit - callProcess "javac" [src] - -- A single compilation unit can produce multiple class files. - classFiles <- filter (".class" `isSuffixOf`) <$> listDirectory dir - forM classFiles $ \classFile -> do - bcode <- BS.readFile (dir classFile) - -- Strip the .class suffix. - let klass = "io.tweag.inlinejava." ++ takeWhile (/= '.') classFile - return $ DotClass klass bcode - --- | The names of 'JType' data constructors -data JTypeNames = JTypeNames - { nameClass :: Maybe Name - , nameIface :: Maybe Name - , nameArray :: Maybe Name - , nameGeneric :: Maybe Name - , namePrim :: Maybe Name - , nameVoid :: Maybe Name - } - --- | Produces the names of the data constructors of the 'JType' --- if they are used in the current module. -findJTypeNames :: CoreM JTypeNames -findJTypeNames = do - nameClass <- findTHName 'Class - nameIface <- findTHName 'Iface - nameArray <- findTHName 'Array - nameGeneric <- findTHName 'Generic - namePrim <- findTHName 'Prim - nameVoid <- findTHName 'Void - return $ JTypeNames {..} - --- | Produces a java type from a Core 'Type' if the type is sufficiently --- instantiated and it is of kind 'JType'. -toJavaType :: JTypeNames -> Type -> Maybe BS.ByteString -toJavaType JTypeNames {..} t0 = BS.concat <$> go t0 - where - go :: Type -> Maybe [BS.ByteString] - go (TyConApp c [LitTy (StrTyLit fs)]) - | Just n <- nameClass, tyConName c == n = - Just [substDollar $ fastStringToByteString fs] - | Just n <- nameIface, tyConName c == n = - Just [substDollar $ fastStringToByteString fs] - go (TyConApp c [t]) - | Just n <- nameArray, tyConName c == n = - (++ ["[]"]) <$> go t - go (TyConApp c [t, ts]) - | Just n <- nameGeneric, tyConName c == n = do - bs <- go t - args_ts <- listGo ts - Just $ bs ++ "<" : concat (intersperse [","] args_ts) ++ [">"] - go (TyConApp c []) - | Just n <- nameVoid, tyConName c == n = - Just ["void"] - go (TyConApp c [LitTy (StrTyLit fs)]) - | Just n <- namePrim, tyConName c == n = - Just [fastStringToByteString fs] - go _ = Nothing - - listGo :: Type -> Maybe [[BS.ByteString]] - listGo (TyConApp c [_]) | nilDataConName == tyConName c = Just [] - listGo (TyConApp c [_, tx, txs]) | consDataConName == tyConName c = - (:) <$> go tx <*> listGo txs - listGo _ = Nothing - - -- Substitutes '$' with '.' in java names. - substDollar :: BS.ByteString -> BS.ByteString - substDollar xs - | fromIntegral (ord '$') `BS.elem` xs = - let subst (chr . fromIntegral -> '$') = fromIntegral (ord '.') - subst x = x - in BS.map subst xs - | otherwise = xs - --- | An occurrence of 'qqMarker' -data QQOcc = QQOcc - { -- | The type of the result - qqOccResTy :: Type - -- | The type of the arguments - , qqOccArgTys :: [Type] - -- | The input of the quasiquoter - , qqOccInput :: BS.ByteString - -- | The name of the method to generate - , qqOccMName :: BS.ByteString - -- | The antiquotations of the quasiquoter - , qqOccAntiQs :: BS.ByteString - -- | The line number where the quasiquotation appears - , qqOccLineNumber :: Integer - } - --- | A monad for collecting qqMarker occurrences. -type QQJavaM a = WriterT (Endo [QQOcc]) CoreM a - --- Collects the occurrences of qqMarkers. --- --- The program is expected to have 'qqMarker' occurrences inserted --- by the java quasiquoter. --- --- > module A where --- > import Language.Java.Inline --- > --- > f = ... --- > (qqMarker ... (callStatic "Inline___" "inline__method_i" [])) --- > ... --- > --- > g = ... --- > ... --- --- 'collectQQMarkers' yields one 'QQOcc' value for every occurrences of --- 'qqMarker', and the program resulting from removing the markers. --- --- > module A where --- > import Language.Java.Inline --- > --- > f = ... --- > (callStatic "Inline___" "inline__method_i" []) --- > ... --- > --- > g = ... --- > ... --- -collectQQMarkers - :: Name -> CoreProgram -> CoreM (CoreProgram, [QQOcc]) -collectQQMarkers qqMarkerName p0 = do - (p1, e) <- runWriterT (mapM bindMarkers p0) - return (p1, appEndo e []) - where - bindMarkers :: CoreBind -> QQJavaM CoreBind - bindMarkers (NonRec b e) = NonRec b <$> expMarkers e - bindMarkers (Rec bs) = Rec <$> mapM (\(b, e) -> (,) b <$> expMarkers e) bs - - expMarkers :: CoreExpr -> QQJavaM CoreExpr - expMarkers (App (App (App (App (App (App (App (App (App (App (App (App (App - (App (App (App (App (App (App (App (Var fid) _) - (Type (parseArgTys -> Just tyargs))) - (Type tyres)) - (Type (LitTy (StrTyLit fs_input)))) - (Type (LitTy (StrTyLit fs_mname)))) - (Type (LitTy (StrTyLit fs_antiqs)))) - (Type (LitTy (NumTyLit lineNumber)))) - _) _) _) _) _) _) _) _) _) _) _) _) - e - ) - | qqMarkerName == idName fid = do - tell $ Endo $ (:) $ QQOcc - { qqOccResTy = tyres - , qqOccArgTys = tyargs - , qqOccInput = fastStringToByteString fs_input - , qqOccMName = fastStringToByteString fs_mname - , qqOccAntiQs = fastStringToByteString fs_antiqs - , qqOccLineNumber = lineNumber - } - return e - expMarkers (Var fid) | qqMarkerName == idName fid = lift $ failWith $ - text "inline-java Plugin: found invalid qqMarker." - expMarkers (App e a) = App <$> expMarkers e <*> expMarkers a - expMarkers (Lam b e) = Lam b <$> expMarkers e - expMarkers (Let bnd e) = Let <$> bindMarkers bnd <*> expMarkers e - expMarkers (Case e0 b t alts) = do - e0' <- expMarkers e0 - let expAlt (a, bs, e) = (,,) a bs <$> expMarkers e - alts' <- mapM expAlt alts - return (Case e0' b t alts') - expMarkers (Cast e c) = flip Cast c <$> expMarkers e - expMarkers (Tick t e) = Tick t <$> expMarkers e - expMarkers e@(Coercion {}) = return e - expMarkers e@(Lit {}) = return e - expMarkers e@(Var {}) = return e - expMarkers e@(Type {}) = return e - - -- @parseArgTys (t_1, (t_2, ... (t_n, ()) ... )) = Just [t_1, t_2, ... t_n]@ - -- - -- Yields @Nothing@ when the input is not of the expected form. - parseArgTys :: Type -> Maybe [Type] - parseArgTys (TyConApp c [_, _, ty, tys]) - | c == promotedTupleDataCon Boxed 2 = - (ty:) <$> parseArgTys tys - parseArgTys (TyConApp c []) - | c == unitTyCon = - Just [] - parseArgTys _ = Nothing - --- | Produces static structures which contain the class names and --- the bytecodes. For instance: --- --- > static unsigned char bc0[] = {202, 254, ... } --- > --- > static unsigned char bc1[] = {202, 254, ... } --- > --- > static struct inline_java_dot_class dcs[] = --- > { { "io.tweag.inlinejava.Inline__main_Language_Java_InlineSpec" --- > , 2941 // length of bc0 --- > , bc0 --- > } --- > , { "io.tweag.inlinejava.Inline__main_Language_Java_InlineSpec$1Foo" --- > , 579 // length of bc1 --- > , bc1 --- > } --- > }; --- > -dotClasses :: [DotClass] -> SDoc -dotClasses dcs = vcat $ - text "static int dc_count =" <+> int (length dcs) <> semi - : [ vcat - [ text "static unsigned char bc" <> int i <> text "[] =" - , braces (pprWithCommas (text . show) (BS.unpack bc)) <> semi - ] - | (i, DotClass _ bc) <- zip [0..] dcs - ] - ++ - [ text "static struct inline_java_dot_class dcs[] =" - , braces - (pprWithCommas - (\(i, DotClass name bc) -> - braces $ pprWithCommas id - [ text (show name), int (BS.length bc), text "bc" <> int i]) - (zip [0..] dcs) - ) <> semi - ] - --- | Produces the constructor function which inserts the static structures --- generated by 'dotClasses' into the bytecode table. -cConstructors :: SDoc -cConstructors = vcat - [ text "static void hs_inline_java_init(void) __attribute__((constructor));" - , text "static void hs_inline_java_init(void)" - , text "{ inline_java_bctable = inline_java_new_pack(inline_java_bctable, dcs, dc_count); }" - ] - --------------------------------------------- --- Candidates for addition to GhcPlugins --------------------------------------------- - --- | Produces a name in GHC Core from a Template Haskell name. --- --- Yields Nothing if the name can't be found, which may happen if the --- module defining the named thing hasn't been loaded. -findTHName :: TH.Name -> CoreM (Maybe Name) -findTHName th_name = - case thRdrNameGuesses th_name of - Orig m occ : _ -> do - hsc_env <- getHscEnv - nc <- liftIO $ readIORef (hsc_NC hsc_env) - return $ lookupOrigNameCache (nsNames nc) m occ - _ -> return Nothing - --- | Yields module annotations with values of the given type. -getModuleAnnotations :: Data a => ModGuts -> [a] -getModuleAnnotations guts = - mapMaybe (fromSerialized deserializeWithData) - [ v | Annotation (ModuleTarget _) v <- mg_anns guts ] - --- | Prints the given error message and terminates ghc. -failWith :: SDoc -> CoreM a -failWith m = do - errorMsg m - dflags <- getDynFlags - liftIO $ ghcExit dflags 1 - return (error "ghcExit returned!?") -- unreachable diff --git a/src/common/Language/Java/Inline.hs b/src/common/Language/Java/Inline.hs new file mode 100644 --- /dev/null +++ b/src/common/Language/Java/Inline.hs @@ -0,0 +1,5 @@ +-- | This module reexports "Language.Java.Inline.Unsafe". + +module Language.Java.Inline (module Language.Java.Inline.Unsafe) where + +import Language.Java.Inline.Unsafe diff --git a/src/common/Language/Java/Inline/Cabal.hs b/src/common/Language/Java/Inline/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/common/Language/Java/Inline/Cabal.hs @@ -0,0 +1,140 @@ +-- | This module contains Cabal @Setup.hs@ hooks to set the @CLASSPATH@ to use +-- when compiling inline code. The @CLASSPATH@ environment variable specifies +-- where to find JVM package dependencies, such as third party packages +-- downloaded from . +-- +-- You can set the @CLASSPATH@ manually, or extract one from an external build +-- system configuration. Currently supported build systems: +-- +-- * + +module Language.Java.Inline.Cabal + ( gradleHooks + , prependClasspathWithGradle + , gradleBuild + , addJarsToClasspath + ) where + +import Control.Exception (evaluate) +import Control.Monad (when) +import Data.List (intersperse, isPrefixOf) +import Distribution.Simple +import Distribution.Simple.Setup (BuildFlags) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) +import Distribution.PackageDescription +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Environment (lookupEnv, setEnv) +import System.FilePath +import System.IO +import System.IO.Temp (withSystemTempFile) +import System.Process (callProcess, readProcess) + +-- | Adds the 'prependClasspathWithGradle' and 'gradleBuild' hooks. +-- +-- Also adds the jar produced by gradle to the data-files. +gradleHooks :: UserHooks -> UserHooks +gradleHooks hooks = hooks + { preBuild = prependClasspathWithGradle <> preBuild hooks + , buildHook = gradleBuild <> buildHook hooks + , preHaddock = prependClasspathWithGradle <> preHaddock hooks + , instHook = instHook simpleUserHooks . addJarToDataFiles + , copyHook = copyHook simpleUserHooks . addJarToDataFiles + , regHook = regHook simpleUserHooks . addJarToDataFiles + } + +-- | Prepends the given jar paths to the CLASSPATH. +addJarsToClasspath :: [FilePath] -> UserHooks -> UserHooks +addJarsToClasspath extraJars hooks = hooks + { preBuild = setClasspath extraJars <> preBuild hooks + , preHaddock = setClasspath extraJars <> preHaddock hooks + } + +gradleBuildFile :: FilePath +gradleBuildFile = "build.gradle" + +findGradleBuild :: FilePath -> IO (Maybe FilePath) +findGradleBuild cwd = do + let path = cwd gradleBuildFile + yes <- doesFileExist path + if yes then return (Just path) else return Nothing + +-- | Set the @CLASSPATH@ from a Gradle build configuration. Uses the classpath +-- for the @main@ source set. +getGradleClasspath :: FilePath -> IO String +getGradleClasspath parentBuildfile = do + withSystemTempFile "build.gradle" $ \buildfile h -> do + hClose h + writeFile buildfile $ + unlines + [ "apply from: '" ++ parentBuildfile ++ "'" + , "task classpath { doLast { println sourceSets.main.compileClasspath.getAsPath() } }" + ] + readProcess "gradle" ["-q", "-b", buildfile, "classpath"] "" + -- Get the last line of output. Sometimes Gradle prepends garbage to the + -- output despite the -q flag. + >>= return . last . lines + +-- | Prepends the @CLASSPATH@ with the classpath from a Gradle build +-- configuration. +prependClasspathWithGradle :: Args -> b -> IO HookedBuildInfo +prependClasspathWithGradle _ _ = do + here <- getCurrentDirectory + origclasspath <- lookupEnv "CLASSPATH" + mbbuildfile <- findGradleBuild here + case mbbuildfile of + Nothing -> fail $ unwords [gradleBuildFile, "file not found in", here] + Just buildfile -> do + classpath <- getGradleClasspath buildfile + setEnv "CLASSPATH" $ classpath ++ maybe "" (':':) origclasspath + return (Nothing, []) + +setClasspath :: [FilePath] -> a -> b -> IO HookedBuildInfo +setClasspath extraJars _ _ = do + mclasspath <- lookupEnv "CLASSPATH" + setEnv "CLASSPATH" $ + concat $ intersperse ":" $ + maybe extraJars (\c -> extraJars ++ [c]) mclasspath + return (Nothing, []) + +-- | Call @gradle build@ as part of the Cabal build. Useful to e.g. build +-- auxiliary Java source code and to create packages. +gradleBuild :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () +gradleBuild pd _ _ _ = do + setProjectName + callProcess "gradle" ["build"] + where + settingsFile = "settings.gradle" + + setProjectName :: IO () + setProjectName = do + missingProjectName <- isProjectNameMissing + when missingProjectName $ + appendFile "settings.gradle" $ + "\nrootProject.name = '" ++ + unPackageName (pkgName (package pd)) ++ "'\n" + + isProjectNameMissing :: IO Bool + isProjectNameMissing = do + exists <- doesFileExist settingsFile + if not exists + then return True + else withFile settingsFile ReadMode $ \h -> do + b <- all (not . ("rootProject.name =" `isPrefixOf`)) . lines + <$> hGetContents h + -- If we don't evaluate the boolean before returning, the + -- file handle will be closed when we try to read the file. + evaluate b + +-- ".jar" is a file build by gradle during building. This file needs +-- to be installed together with the library, otherwise it wouldn't be available +-- to build other code depending on it. Therefore, we add the jar to the field +-- dataFiles in the hooks instHook, copyHook and regHook. This way the jar is +-- installed, but cabal does not account it when deciding if the package needs +-- to be rebuilt. + +addJarToDataFiles :: PackageDescription -> PackageDescription +addJarToDataFiles pd = pd + { dataFiles = + ("build/libs" unPackageName (pkgName (package pd)) <.> "jar") + : dataFiles pd + } diff --git a/src/common/Language/Java/Inline/Internal.hs b/src/common/Language/Java/Inline/Internal.hs new file mode 100644 --- /dev/null +++ b/src/common/Language/Java/Inline/Internal.hs @@ -0,0 +1,206 @@ +-- | = Inline Java quasiquotation +-- +-- See the +-- +-- for an introduction to quasiquotation. The quasiquoter exported in this +-- module allows embedding arbitrary Java expressions and blocks of statements +-- inside Haskell code. You can call any Java method and define arbitrary inline +-- code using Java syntax. No FFI required. +-- +-- Here is the same example as in "Language.Java", but with inline Java calls: +-- +-- @ +-- {-\# LANGUAGE DataKinds \#-} +-- {-\# LANGUAGE QuasiQuotes \#-} +-- module Object where +-- +-- import Language.Java as J +-- import Language.Java.Inline +-- +-- newtype Object = Object ('J' (''Class' "java.lang.Object")) +-- instance 'Coercible' Object +-- +-- clone :: Object -> IO Object +-- clone obj = [java| $obj.clone() |] +-- +-- equals :: Object -> Object -> IO Bool +-- equals obj1 obj2 = [java| $obj1.equals($obj2) |] +-- +-- ... +-- @ + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Language.Java.Inline.Internal + ( javaWithConfig + , QQConfig(..) + , imports + , loadJavaWrappers + ) where + +import Control.Monad (when) +import Data.Data +import Data.List (isPrefixOf, intercalate, isSuffixOf, nub) +import Data.String (fromString) +import Foreign.JNI (defineClass) +import Language.Java +import Language.Java.Inline.Internal.Magic as Magic +import qualified Language.Java.Lexer as Java +import Language.Haskell.TH.Quote +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH +import Language.Haskell.TH (Q) +import System.IO.Unsafe (unsafePerformIO) + +-- Implementation strategy +-- +-- We know we'll need to declare a new wrapper (a Java static method), but we +-- don't know the types of the arguments nor the return type. So we first name +-- this method and generate a Haskell call to it at the quasiquotation site. +-- Then, we inject a call to 'qqMarker' which carries the needed types to the +-- plugin phase. +-- +-- The plugin phase is implemented in Language.Java.Inline.Plugin. In this phase +-- we make a pass over the module Core to find all the occurrences of +-- 'qqMarker'. By this point the types of all the variables in the local scope +-- that was captured are fully determined. So we can analyze these types to +-- determine what the signature of the wrapper should be, in order to declare +-- it. +-- +-- The last step is to ask the Java toolchain to produce .class bytecode from +-- our declarations. We embed this bytecode in the binary, adding a reference to +-- it in a global bytecode table. That way at runtime we can enumerate +-- the bytecode blobs, and load them into the JVM one by one. + +javaWithConfig :: QQConfig -> QuasiQuoter +javaWithConfig config = QuasiQuoter + { quoteExp = \txt -> blockOrExpQQ config txt + , quotePat = error "Language.Java.Inline: quotePat" + , quoteType = error "Language.Java.Inline: quoteType" + , quoteDec = error "Language.Java.Inline: quoteDec" + } + +-- | Private newtype to key the TH state. +newtype IJState = IJState { methodCount :: Integer } + +initialIJState :: IJState +initialIJState = IJState 0 + +getIJState :: Q IJState +getIJState = TH.getQ >>= \case + Nothing -> do + TH.putQ initialIJState + return initialIJState + Just st -> return st + +setIJState :: IJState -> Q () +setIJState = TH.putQ + +-- | Declares /import/ statements to be included in the java compilation unit. +-- e.g. +-- +-- > imports "java.util.*" +-- +imports :: String -> Q [TH.Dec] +imports imp = do + tJI <- [t| Magic.JavaImport |] + lineNumber <- fromIntegral . fst . TH.loc_start <$> TH.location + expJI <- TH.lift (Magic.JavaImport imp lineNumber) + TH.addTopDecls + -- {-# ANN module (JavaImport imp :: JavaImport) #-} + [ TH.PragmaD $ TH.AnnP TH.ModuleAnnotation (TH.SigE expJI tJI) ] + return [] + +-- | Yields the next method index. A different index is produced per call. +nextMethodIdx :: Q Integer +nextMethodIdx = do + ij <- getIJState + setIJState $ ij { methodCount = methodCount ij + 1 } + return $ methodCount ij + +-- | Idempotent action that loads all wrappers in every module of the current +-- program into the JVM. You shouldn't need to call this yourself. +loadJavaWrappers :: IO () +loadJavaWrappers = doit `seq` return () + where + {-# NOINLINE doit #-} + doit = unsafePerformIO $ push $ do + loader :: J ('Class "java.lang.ClassLoader") <- do + thr <- callStatic "java.lang.Thread" "currentThread" + call (thr :: J ('Class "java.lang.Thread")) "getContextClassLoader" + Magic.forEachDotClass $ \Magic.DotClass{..} -> do + _ <- defineClass (referenceTypeName (SClass className)) loader classBytecode + return () + pop + +mangle :: TH.Module -> String +mangle (TH.Module (TH.PkgName pkgname) (TH.ModName mname)) = + Magic.mangleClassName pkgname mname + +-- | Customizes how quasiquotations are desugared. +data QQConfig = QQConfig + { -- | This is the name of the function to use to indicate to the + -- plugin the presence of a java quasiquotation. + qqMarker :: TH.Name + -- | This produces the call invoke the Java stub. + -- It takes the list of arguments that should be passed to the call. + , qqCallStatic :: [TH.ExpQ] -> TH.ExpQ + -- | This is given as argument the invocation of the Java stub, and + -- is expected to prepend it with code that ensures that the stub is + -- previously loaded in the JVM. + , qqWrapMarker :: TH.ExpQ -> TH.ExpQ + } + +blockOrExpQQ :: QQConfig -> String -> Q TH.Exp +blockOrExpQQ config txt@(words -> toks) -- ignore whitespace + | ["{"] `isPrefixOf` toks + , ["}"] `isSuffixOf` toks = blockQQ config txt + | otherwise = expQQ config txt + +expQQ :: QQConfig ->String -> Q TH.Exp +expQQ config input = blockQQ config $ "{ return " ++ input ++ "; }" + +blockQQ :: QQConfig -> String -> Q TH.Exp +blockQQ config input = do + idx <- nextMethodIdx + when (idx == 0) $ + TH.addCorePlugin "Language.Java.Inline.Plugin" + let mname = "inline__method_" ++ show idx + vnames = nub + [ n | Java.L _ (Java.IdentTok ('$' : n)) <- Java.lexer input ] + thnames = map TH.mkName vnames + thnames' = map TH.mkName (map ('_':) vnames) + + -- Return a call to the static method we just generated. + thismod <- TH.thisModule + lineNumber <- fromIntegral . fst . TH.loc_start <$> TH.location + qqWrapMarker config + [| $(TH.varE (qqMarker config)) + (Proxy :: Proxy $(TH.litT $ TH.strTyLit input)) + (Proxy :: Proxy $(TH.litT $ TH.strTyLit mname)) + (Proxy :: Proxy $(TH.litT $ TH.strTyLit $ intercalate "," vnames)) + (Proxy :: Proxy $(TH.litT $ TH.numTyLit $ lineNumber)) + $(return $ foldr (\a b -> TH.TupE [Just $ TH.VarE a, Just b]) (TH.TupE []) thnames) + Proxy + (\ $(return $ foldr (\a b -> TH.TupP [TH.VarP a, b]) (TH.TupP []) thnames') -> + $(qqCallStatic config $ + [ [| fromString $(TH.stringE ("io.tweag.inlinejava." ++ mangle thismod)) |] + , [| fromString $(TH.stringE mname) |] + ] ++ map TH.varE thnames' + ) + ) + |] diff --git a/src/common/Language/Java/Inline/Internal/Magic.hsc b/src/common/Language/Java/Inline/Internal/Magic.hsc new file mode 100644 --- /dev/null +++ b/src/common/Language/Java/Inline/Internal/Magic.hsc @@ -0,0 +1,81 @@ +-- | Internal module defining some magic, kept separate from the rest, that +-- depends on compiler internals. + +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.Java.Inline.Internal.Magic + ( DotClass(..) + , JavaImport(..) + , forEachDotClass + , mangleClassName + ) where + +import Control.Monad (forM_) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Unsafe as BS +import Data.Char (isAlphaNum) +import Data.Data +import Foreign.C.String (peekCString) +import Foreign.C.Types (CSize) +import Foreign.Ptr (Ptr, nullPtr, plusPtr) +import Foreign.Storable +import qualified Language.Haskell.TH.Syntax as TH + +#include "bctable.h" + +-- | The bytecode corresponding to a java class +data DotClass = DotClass + { className :: String + , classBytecode :: ByteString + } + +data JavaImport = JavaImport String Integer + deriving (Data, TH.Lift) + +-- | Produces a Java class name from a package and a module name. +mangleClassName :: String -> String -> String +mangleClassName pkgname modname = concat + [ "Inline__" + , filter isAlphaNum pkgname + , "_" + , map (\case '.' -> '_'; x -> x) modname + ] + +foreign import capi unsafe "&inline_java_bctable" bctable :: Ptr (Ptr DotClass) + +peekDotClass :: Ptr DotClass -> IO DotClass +peekDotClass ptr = do + sz <- #{peek struct inline_java_dot_class, bytecode_sz} ptr + bc <- #{peek struct inline_java_dot_class, bytecode} ptr + DotClass + <$> (#{peek struct inline_java_dot_class, name} ptr >>= peekCString) + <*> (BS.unsafePackCStringLen (bc, fromIntegral (sz :: CSize))) + +-- | Runs the given function for every class in the bytecode table. +forEachDotClass :: (DotClass -> IO ()) -> IO () +forEachDotClass f = peek bctable >>= go + where + go :: Ptr DotClass -> IO () + go tbl + | tbl == nullPtr = return () + | otherwise = do + dcs_ptr <- #{peek struct inline_java_pack, classes} tbl + tbl_sz <- #{peek struct inline_java_pack, size} tbl + forM_ [0..(tbl_sz-1)] $ \i -> do + let dc_sz = #{size struct inline_java_dot_class} + f =<< peekDotClass (dcs_ptr `plusPtr` (i * dc_sz)) + #{peek struct inline_java_pack, next} tbl >>= go diff --git a/src/common/Language/Java/Inline/Internal/QQMarker.hs b/src/common/Language/Java/Inline/Internal/QQMarker.hs new file mode 100644 --- /dev/null +++ b/src/common/Language/Java/Inline/Internal/QQMarker.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Language.Java.Inline.Internal.QQMarker where + +import Data.Proxy +import GHC.Stack (HasCallStack, withFrozenCallStack) +import GHC.TypeLits (Nat, Symbol) +import Language.Java + +-- | A function to indicate to the plugin the occurrence +-- of java quasiquotations +qqMarker + :: forall + k + (args_tys :: k) -- JType's of arguments + tyres -- JType of result + (input :: Symbol) -- input string of the quasiquoter + (mname :: Symbol) -- name of the method to generate + (antiqs :: Symbol) -- antiquoted variables as a comma-separated list + (line :: Nat) -- line number of the quasiquotation + args_tuple -- uncoerced argument types + b -- uncoerced result type + m. + ( tyres ~ Ty b + , Coercibles args_tuple args_tys + , Coercible b + , HasCallStack + ) + => Proxy input + -> Proxy mname + -> Proxy antiqs + -> Proxy line + -> args_tuple + -> Proxy args_tys + -> (args_tuple -> m b) + -> m b +qqMarker = withFrozenCallStack $ + error + "A quasiquotation marker was not removed. Please, report this as a bug." + +class Coercibles xs (tys :: k) | xs -> tys +instance Coercibles () () +instance (ty ~ Ty x, Coercible x, Coercibles xs tys) + => Coercibles (x, xs) '(ty, tys) diff --git a/src/common/Language/Java/Inline/Plugin.hs b/src/common/Language/Java/Inline/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/common/Language/Java/Inline/Plugin.hs @@ -0,0 +1,459 @@ +-- | This plugin generates Java bytecode from modules using the java +-- QuasiQuoter and inserts it in a global bytecode table from where +-- it is loaded at runtime. +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +module Language.Java.Inline.Plugin (plugin) where + +import Control.Applicative ((<|>)) +import Control.Monad.Writer hiding ((<>)) +import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as Builder +import Data.Char (chr, ord) +import Data.List (find, intersperse, isSuffixOf) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified FastString.Extras +import Foreign.JNI.Types (JType(..)) +import GhcPlugins.Extras +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH +import Language.Java.Inline.Internal.Magic +import Language.Java.Inline.Internal.QQMarker.Names (getQQMarkers) +import System.Directory (listDirectory) +import System.FilePath ((), (<.>), takeDirectory) +import System.IO (withFile, IOMode(WriteMode), hPutStrLn, stderr) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (callProcess) +import Prelude hiding ((<>)) + +-- The 'java' quasiquoter produces annotations of type 'JavaImport', and it also +-- inserts calls in the code to the function 'qqMarker'. +-- +-- 'qqMarker' carries many bits of information that are useful in generating the +-- QQ code. +-- +-- This plugin first makes a pass to collect the 'qqMarker' calls in the module +-- (collectQQMarkers). +-- +-- Then it translates the Core Types to Java types (unliftJTypes). +-- +-- Then it generates the java stubs from the information extracted from the +-- occurrences of 'qqMarker' (buildJava). +-- +-- Finally, it calls the java compiler to produce the bytecode and +-- arranges to have it inserted in the bytecode table in constructor functions +-- (cConstructors). + +plugin :: Plugin +plugin = defaultPlugin + { installCoreToDos = install + , pluginRecompile = flagRecompile + } + where + install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] + install args todo = do + let passName = "inline-java" + if inTodo passName todo then return todo + else return (CoreDoPluginPass passName (qqPass args) : todo) + + inTodo :: String -> [CoreToDo] -> Bool + inTodo name = \case + CoreDoPluginPass n _ : xs -> n == name || inTodo name xs + _ : xs -> inTodo name xs + [] -> False + + qqPass :: [CommandLineOption] -> ModGuts -> CoreM ModGuts + qqPass args guts = do + getQQMarkers >>= \case + -- If qqMarkers cannot be found we assume the module does not use + -- inline-java. + [] -> return guts + qqMarkerNames -> do + (binds, qqOccs) <- collectQQMarkers qqMarkerNames (mg_binds guts) + let jimports = + GhcPlugins.Extras.getModuleAnnotations guts :: [JavaImport] + dcs <- buildJava guts qqOccs jimports + >>= maybeDumpJava args + >>= buildBytecode args + return guts + { mg_binds = binds + , mg_foreign = appendStubC (mg_foreign guts) $ + text bctable_header + $$ dotClasses dcs + $$ cConstructors + } + + -- The contents of bctable.h + -- + -- #include "bctable.h" wouldn't work when ghc is used from the + -- command line without saying -package inline-java. + bctable_header :: String + bctable_header = $(do + loc <- TH.location + let root = iterate takeDirectory (TH.loc_filename loc) !! 6 + f = root "cbits/bctable.h" + TH.addDependentFile f + TH.lift =<< TH.runIO (readFile f) + ) + -- Dumps the java code to stderr or a file, depending on the set flags. + maybeDumpJava :: [CommandLineOption] -> Builder -> CoreM Builder + maybeDumpJava args b + | elem "dump-java" args = do + dflags <- getDynFlags + if gopt Opt_DumpToFile dflags then do + thisModule <- getModule + let fname = moduleNameString (moduleName thisModule) ++ ".dump-java" + path = maybe fname ( fname) (dumpDir dflags) + liftIO $ withFile path WriteMode $ \h -> Builder.hPutBuilder h b + else liftIO $ do + hPutStrLn stderr "=== inline-java (dump-java) BEGIN ===" + Builder.hPutBuilder stderr b + hPutStrLn stderr "=== inline-java (dump-java) END ===" + return b + maybeDumpJava _ b = return b + +-- | Produces a Java compilation unit from the quasiquotation occurrences and +-- the java imports. +-- +-- The compilation unit looks like: +-- +-- > package io.tweag.inlinejava; +-- > import java.util.*; // .hs:25 +-- > +-- > public final class Inline___ { +-- > public static java.lang.Object method_0() +-- > { return 1 + 1 ; } // .hs:31 +-- > public static java.lang.Object inline__method_1() +-- > { // .hs:34 +-- > int x = 1; // .hs:34 +-- > int y = 2; // .hs:34 +-- > return x + y; // .hs:34 +-- > } // .hs:34 +-- > public static java.lang.Object inline__method_2(final int $x) +-- > { return $x + 1 ; } // .hs:42 +-- > public static java.lang.Object inline__method_3() +-- > { return new Object() {} ; } // .hs:46 +-- > } +-- +-- Where @inline_method_i@ is the method corresponding to the @ith@ +-- quasiquotation. +buildJava :: ModGuts -> [QQOcc] -> [JavaImport] -> CoreM Builder +buildJava guts qqOccs jimports = do + let importsJava = mconcat + [ mconcat [ "import ", Builder.stringUtf8 jimp + , "; // .hs:", Builder.integerDec n + , "\n" + ] + | JavaImport jimp n <- jimports + ] + p_fam_env <- getPackageFamInstEnv + let fam_envs = (p_fam_env, mg_fam_inst_env guts) + methods <- forM qqOccs $ \QQOcc {..} -> do + let (_, normty) = normaliseType fam_envs Nominal (expandTypeSynonyms qqOccResTy) + jTypeNames <- findJTypeNames + resty <- case toJavaType jTypeNames normty of + Just resty -> return resty + Nothing -> GhcPlugins.Extras.failWith $ hsep + [ parens (text "line" <+> integer qqOccLineNumber) <> ":" + , text "The result type of the quasiquotation" + , quotes (ppr qqOccResTy) + , text "is not sufficiently instantiated to infer a java type." + ] + let argnames = BS.split (fromIntegral $ fromEnum ',') qqOccAntiQs + argtys <- zipWithM (getArg jTypeNames qqOccLineNumber) + argnames qqOccArgTys + return $ mconcat + [ "public static " + , Builder.byteString resty + , " " + , Builder.byteString qqOccMName + , "(" + , mconcat $ intersperse "," argtys + , ") throws Throwable // .hs:" + , Builder.integerDec qqOccLineNumber + , "\n" + , adjustInput qqOccLineNumber qqOccInput + ] + thisModule <- getModule + let className = mangle thisModule + return $ mconcat + [ "package io.tweag.inlinejava;\n" + , importsJava + , "\n" + , "public final class " + , Builder.stringUtf8 className + , " {\n" + , mconcat methods + , "}\n" + ] + where + getArg :: JTypeNames -> Integer -> BS.ByteString -> Type -> CoreM Builder + getArg jTypeNames _ name + (expandTypeSynonyms -> toJavaType jTypeNames -> Just jtype) = + return $ mconcat + ["final ", Builder.byteString jtype, " $", Builder.byteString name] + getArg _ line name t = GhcPlugins.Extras.failWith $ hsep + [ parens (text "line" <+> integer line) <> ":" + , quotes (ftext (mkFastStringByteString name) <+> "::" <+> ppr t) + , text "is not sufficiently instantiated to infer a java type." + ] + + adjustInput :: Integer -> BS.ByteString -> Builder + adjustInput lineNumber bs = + let txt = Text.strip $ Text.decodeUtf8 bs + block = if Text.isPrefixOf "{" txt && Text.isSuffixOf "}" txt + then Text.lines txt + else Text.lines $ Text.concat ["{ return ", txt, "}" ] + + in Builder.byteString $ Text.encodeUtf8 $ Text.unlines + [ Text.concat [ln, " // .hs:", Text.pack (show lineNumber)] + | ln <- block + ] + +-- | Produces a class name from a Module. +mangle :: Module -> String +mangle m = mangleClassName (unitIdString $ moduleUnitId m) + (moduleNameString (moduleName m)) + +-- Call the java compiler and feeds it the given Java code in Builder form. +buildBytecode :: [CommandLineOption] -> Builder -> CoreM [DotClass] +buildBytecode args unit = do + let Just javac = find ("javac" `isSuffixOf`) args <|> return "javac" + m <- getModule + liftIO $ withSystemTempDirectory "inlinejava" $ \dir -> do + let src = dir mangle m <.> "java" + withFile src WriteMode $ \h -> Builder.hPutBuilder h unit + callProcess javac [src] + -- A single compilation unit can produce multiple class files. + classFiles <- filter (".class" `isSuffixOf`) <$> listDirectory dir + forM classFiles $ \classFile -> do + bcode <- BS.readFile (dir classFile) + -- Strip the .class suffix. + let klass = "io.tweag.inlinejava." ++ takeWhile (/= '.') classFile + return $ DotClass klass bcode + +-- | The names of 'JType' data constructors +data JTypeNames = JTypeNames + { nameClass :: Maybe Name + , nameIface :: Maybe Name + , nameArray :: Maybe Name + , nameGeneric :: Maybe Name + , namePrim :: Maybe Name + , nameVoid :: Maybe Name + } + +-- | Produces the names of the data constructors of the 'JType' +-- if they are used in the current module. +findJTypeNames :: CoreM JTypeNames +findJTypeNames = do + nameClass <- GhcPlugins.Extras.findTHName 'Class + nameIface <- GhcPlugins.Extras.findTHName 'Iface + nameArray <- GhcPlugins.Extras.findTHName 'Array + nameGeneric <- GhcPlugins.Extras.findTHName 'Generic + namePrim <- GhcPlugins.Extras.findTHName 'Prim + nameVoid <- GhcPlugins.Extras.findTHName 'Void + return $ JTypeNames {..} + +-- | Produces a java type from a Core 'Type' if the type is sufficiently +-- instantiated and it is of kind 'JType'. +toJavaType :: JTypeNames -> Type -> Maybe BS.ByteString +toJavaType JTypeNames {..} t0 = BS.concat <$> go t0 + where + go :: Type -> Maybe [BS.ByteString] + go (TyConApp c [LitTy (StrTyLit fs)]) + | Just n <- nameClass, tyConName c == n = + Just [substDollar $ FastString.Extras.bytesFS fs] + | Just n <- nameIface, tyConName c == n = + Just [substDollar $ FastString.Extras.bytesFS fs] + go (TyConApp c [t]) + | Just n <- nameArray, tyConName c == n = + (++ ["[]"]) <$> go t + go (TyConApp c [t, ts]) + | Just n <- nameGeneric, tyConName c == n = do + bs <- go t + args_ts <- listGo ts + Just $ bs ++ "<" : concat (intersperse [","] args_ts) ++ [">"] + go (TyConApp c []) + | Just n <- nameVoid, tyConName c == n = + Just ["void"] + go (TyConApp c [LitTy (StrTyLit fs)]) + | Just n <- namePrim, tyConName c == n = + Just [FastString.Extras.bytesFS fs] + go _ = Nothing + + listGo :: Type -> Maybe [[BS.ByteString]] + listGo (TyConApp c [_]) | nilDataConName == tyConName c = Just [] + listGo (TyConApp c [_, tx, txs]) | consDataConName == tyConName c = + (:) <$> go tx <*> listGo txs + listGo _ = Nothing + + -- Substitutes '$' with '.' in java names. + substDollar :: BS.ByteString -> BS.ByteString + substDollar xs + | fromIntegral (ord '$') `BS.elem` xs = + let subst (chr . fromIntegral -> '$') = fromIntegral (ord '.') + subst x = x + in BS.map subst xs + | otherwise = xs + +-- | An occurrence of a java quasiquotation +data QQOcc = QQOcc + { -- | The type of the result + qqOccResTy :: Type + -- | The type of the arguments + , qqOccArgTys :: [Type] + -- | The input of the quasiquoter + , qqOccInput :: BS.ByteString + -- | The name of the method to generate + , qqOccMName :: BS.ByteString + -- | The antiquotations of the quasiquoter + , qqOccAntiQs :: BS.ByteString + -- | The line number where the quasiquotation appears + , qqOccLineNumber :: Integer + } + +-- | A monad for collecting qqMarker occurrences. +type QQJavaM a = WriterT (Endo [QQOcc]) CoreM a + +-- Collects the occurrences of qqMarkers. +-- +-- The program is expected to have 'qqMarker' occurrences inserted +-- by the java quasiquoter. +-- +-- > module A where +-- > import Language.Java.Inline +-- > +-- > f = ... +-- > (qqMarker ... (callStatic "Inline___" "inline__method_i" [])) +-- > ... +-- > +-- > g = ... +-- > ... +-- +-- 'collectQQMarkers' yields one 'QQOcc' value for every occurrence of +-- 'qqMarker', and the program resulting from removing the markers. +-- +-- > module A where +-- > import Language.Java.Inline +-- > +-- > f = ... +-- > (callStatic "Inline___" "inline__method_i" []) +-- > ... +-- > +-- > g = ... +-- > ... +-- +collectQQMarkers + :: [Name] -> CoreProgram -> CoreM (CoreProgram, [QQOcc]) +collectQQMarkers qqMarkerNames p0 = do + (p1, e) <- runWriterT (mapM bindMarkers p0) + return (p1, appEndo e []) + where + bindMarkers :: CoreBind -> QQJavaM CoreBind + bindMarkers (NonRec b e) = NonRec b <$> expMarkers e + bindMarkers (Rec bs) = Rec <$> mapM (\(b, e) -> (,) b <$> expMarkers e) bs + + expMarkers :: CoreExpr -> QQJavaM CoreExpr + expMarkers (App (App (App (App (App (App (App (App (App (App (App (App (App + (App (App (App (App (App (App (App (App (Var fid) _) + (Type (parseArgTys -> Just tyargs))) + (Type tyres)) + (Type (LitTy (StrTyLit fs_input)))) + (Type (LitTy (StrTyLit fs_mname)))) + (Type (LitTy (StrTyLit fs_antiqs)))) + (Type (LitTy (NumTyLit lineNumber)))) + _) _) _) _) _) _) _) _) _) _) _) args) _) + e + ) + | elem (idName fid) qqMarkerNames = do + tell $ Endo $ (:) $ QQOcc + { qqOccResTy = tyres + , qqOccArgTys = tyargs + , qqOccInput = FastString.Extras.bytesFS fs_input + , qqOccMName = FastString.Extras.bytesFS fs_mname + , qqOccAntiQs = FastString.Extras.bytesFS fs_antiqs + , qqOccLineNumber = lineNumber + } + return (App e args) + expMarkers (Var fid) | elem (idName fid) qqMarkerNames = + lift $ GhcPlugins.Extras.failWith $ + text "inline-java Plugin: found invalid qqMarker." + expMarkers (App e a) = App <$> expMarkers e <*> expMarkers a + expMarkers (Lam b e) = Lam b <$> expMarkers e + expMarkers (Let bnd e) = Let <$> bindMarkers bnd <*> expMarkers e + expMarkers (Case e0 b t alts) = do + e0' <- expMarkers e0 + let expAlt (a, bs, e) = (,,) a bs <$> expMarkers e + alts' <- mapM expAlt alts + return (Case e0' b t alts') + expMarkers (Cast e c) = flip Cast c <$> expMarkers e + expMarkers (Tick t e) = Tick t <$> expMarkers e + expMarkers e@(Coercion {}) = return e + expMarkers e@(Lit {}) = return e + expMarkers e@(Var {}) = return e + expMarkers e@(Type {}) = return e + + -- @parseArgTys (t_1, (t_2, ... (t_n, ()) ... )) = Just [t_1, t_2, ... t_n]@ + -- + -- Yields @Nothing@ when the input is not of the expected form. + parseArgTys :: Type -> Maybe [Type] + parseArgTys (TyConApp c [_, _, ty, tys]) + | c == promotedTupleDataCon Boxed 2 = + (ty:) <$> parseArgTys tys + parseArgTys (TyConApp c []) + | c == unitTyCon = + Just [] + parseArgTys _ = Nothing + +-- | Produces static structures which contain the class names and +-- the bytecodes. For instance: +-- +-- > static unsigned char bc0[] = {202, 254, ... } +-- > +-- > static unsigned char bc1[] = {202, 254, ... } +-- > +-- > static struct inline_java_dot_class dcs[] = +-- > { { "io.tweag.inlinejava.Inline__main_Language_Java_InlineSpec" +-- > , 2941 // length of bc0 +-- > , bc0 +-- > } +-- > , { "io.tweag.inlinejava.Inline__main_Language_Java_InlineSpec$1Foo" +-- > , 579 // length of bc1 +-- > , bc1 +-- > } +-- > }; +-- > +dotClasses :: [DotClass] -> SDoc +dotClasses dcs = vcat $ + text "static int dc_count =" <+> int (length dcs) <> semi + : [ vcat + [ text "static unsigned char bc" <> int i <> text "[] =" + , braces (pprWithCommas (text . show) (BS.unpack bc)) <> semi + ] + | (i, DotClass _ bc) <- zip [0..] dcs + ] + ++ + [ text "static struct inline_java_dot_class dcs[] =" + , braces + (pprWithCommas + (\(i, DotClass name bc) -> + braces $ pprWithCommas id + [ text (show name), int (BS.length bc), text "bc" <> int i]) + (zip [0..] dcs) + ) <> semi + ] + +-- | Produces the constructor function which inserts the static structures +-- generated by 'dotClasses' into the bytecode table. +cConstructors :: SDoc +cConstructors = vcat + [ text "static void hs_inline_java_init(void) __attribute__((constructor));" + , text "static void hs_inline_java_init(void)" + , text "{ inline_java_bctable = inline_java_new_pack(inline_java_bctable, dcs, dc_count); }" + ] diff --git a/src/common/Language/Java/Inline/Unsafe.hs b/src/common/Language/Java/Inline/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/common/Language/Java/Inline/Unsafe.hs @@ -0,0 +1,90 @@ +-- | = Inline Java quasiquotation +-- +-- See the +-- +-- for an introduction to quasiquotation. The quasiquoter exported in this +-- module allows embedding arbitrary Java expressions and blocks of statements +-- inside Haskell code. You can call any Java method and define arbitrary inline +-- code using Java syntax. No FFI required. +-- +-- Here is the same example as in "Language.Java", but with inline Java calls: +-- +-- @ +-- {-\# LANGUAGE DataKinds \#-} +-- {-\# LANGUAGE QuasiQuotes \#-} +-- module Object where +-- +-- import Language.Java as J +-- import Language.Java.Inline.Unsafe +-- +-- newtype Object = Object ('J' (''Class' "java.lang.Object")) +-- instance 'Coercible' Object +-- +-- clone :: Object -> IO Object +-- clone obj = [java| $obj.clone() |] +-- +-- equals :: Object -> Object -> IO Bool +-- equals obj1 obj2 = [java| $obj1.equals($obj2) |] +-- +-- ... +-- @ +-- +-- The functions in this module are considered unsafe in opposition +-- to those in "Language.Java.Inline.Safe", which ensure that local +-- references are not leaked. +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Language.Java.Inline.Unsafe + ( java + , imports + , loadJavaWrappers + ) where + +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote +import Language.Java +import Language.Java.Inline.Internal +import qualified Language.Java.Inline.Internal.QQMarker as QQMarker + +-- | Java code quasiquoter. Example: +-- +-- @ +-- imports "javax.swing.JOptionPane" +-- +-- hello :: IO () +-- hello = do +-- message <- reflect ("Hello World!" :: Text) +-- [java| JOptionPane.showMessageDialog(null, $message) |] +-- @ +-- +-- A quasiquote is a snippet of Java code. The code is assumed to be a block +-- (sequence of statements) if the first non whitespace character is a @{@ +-- (curly brace) character. Otherwise it's parsed as an expression. Variables +-- with an initial @$@ (dollar) sign are allowed. They have a special meaning: +-- they stand for antiqotation variables (think of them as format specifiers in +-- printf format string). An antiquotation variable @$foo@ is well-scoped if +-- there exists a variable with the name @foo@ in the Haskell context of the +-- quasiquote, whose type is 'Coercible' to a Java primitive or reference type. +-- +java :: QuasiQuoter +java = javaWithConfig QQConfig + { qqMarker = 'QQMarker.qqMarker + , qqCallStatic = \qargs -> TH.appsE $ TH.varE 'callStatic : qargs + , qqWrapMarker = \qExp -> [| loadJavaWrappers >> $qExp |] + } diff --git a/src/ghc-8.10/FastString/Extras.hs b/src/ghc-8.10/FastString/Extras.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.10/FastString/Extras.hs @@ -0,0 +1,3 @@ +module FastString.Extras(bytesFS) where + +import FastString diff --git a/src/ghc-8.10/GhcPlugins/Extras.hs b/src/ghc-8.10/GhcPlugins/Extras.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.10/GhcPlugins/Extras.hs @@ -0,0 +1,49 @@ +-- | Candidates for addition to GhcPlugins + +module GhcPlugins.Extras + ( module FamInstEnv + , module GhcPlugins + , module GhcPlugins.Extras + , module TyCoRep + ) where + +import Control.Monad.Writer hiding ((<>)) +import Data.Data (Data) +import Data.Maybe (mapMaybe) +import Data.IORef (readIORef) +import ErrUtils (ghcExit) +import FamInstEnv (normaliseType) +import GhcPlugins +import GHC.ThToHs (thRdrNameGuesses) +import IfaceEnv (lookupOrigNameCache) +import qualified Language.Haskell.TH as TH +import NameCache (nsNames) +import TyCoRep + + +-- | Produces a name in GHC Core from a Template Haskell name. +-- +-- Yields Nothing if the name can't be found, which may happen if the +-- module defining the named thing hasn't been loaded. +findTHName :: TH.Name -> CoreM (Maybe Name) +findTHName th_name = + case thRdrNameGuesses th_name of + Orig m occ : _ -> do + hsc_env <- getHscEnv + nc <- liftIO $ readIORef (hsc_NC hsc_env) + return $ lookupOrigNameCache (nsNames nc) m occ + _ -> return Nothing + +-- | Yields module annotations with values of the given type. +getModuleAnnotations :: Data a => ModGuts -> [a] +getModuleAnnotations guts = + mapMaybe (fromSerialized deserializeWithData) + [ v | Annotation (ModuleTarget _) v <- mg_anns guts ] + +-- | Prints the given error message and terminates ghc. +failWith :: SDoc -> CoreM a +failWith m = do + errorMsg m + dflags <- getDynFlags + liftIO $ ghcExit dflags 1 + return (error "ghcExit returned!?") -- unreachable diff --git a/src/ghc-8.11/FastString/Extras.hs b/src/ghc-8.11/FastString/Extras.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.11/FastString/Extras.hs @@ -0,0 +1,3 @@ +module FastString.Extras(bytesFS) where + +import GHC.Data.FastString diff --git a/src/ghc-8.11/GhcPlugins/Extras.hs b/src/ghc-8.11/GhcPlugins/Extras.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.11/GhcPlugins/Extras.hs @@ -0,0 +1,51 @@ +-- | Candidates for addition to GhcPlugins + +module GhcPlugins.Extras + ( module GHC.Core.FamInstEnv + , module GHC.Plugins + , module GhcPlugins.Extras + , module GHC.Core.TyCo.Rep + ) where + +import Control.Monad.Writer hiding ((<>)) +import Data.Data (Data) +import Data.Maybe (mapMaybe) +import Data.IORef (readIORef) +import GHC.Core.FamInstEnv +import GHC.Core.TyCo.Rep +import GHC.Plugins +import GHC.ThToHs (thRdrNameGuesses) +import GHC.Types.Name.Cache (lookupOrigNameCache, nsNames) +import GHC.Utils.Error (ghcExit) +import qualified Language.Haskell.TH as TH + + +-- | Produces a name in GHC Core from a Template Haskell name. +-- +-- Yields Nothing if the name can't be found, which may happen if the +-- module defining the named thing hasn't been loaded. +findTHName :: TH.Name -> CoreM (Maybe Name) +findTHName th_name = + case thRdrNameGuesses th_name of + Orig m occ : _ -> do + hsc_env <- getHscEnv + nc <- liftIO $ readIORef (hsc_NC hsc_env) + return $ lookupOrigNameCache (nsNames nc) m occ + _ -> return Nothing + +-- | Yields module annotations with values of the given type. +getModuleAnnotations :: Data a => ModGuts -> [a] +getModuleAnnotations guts = + mapMaybe (fromSerialized deserializeWithData) + [ v | Annotation (ModuleTarget _) v <- mg_anns guts ] + +-- | Prints the given error message and terminates ghc. +failWith :: SDoc -> CoreM a +failWith m = do + errorMsg m + dflags <- getDynFlags + liftIO $ ghcExit dflags 1 + return (error "ghcExit returned!?") -- unreachable + +moduleUnitId :: GenModule Unit -> UnitId +moduleUnitId = toUnitId . moduleUnit diff --git a/src/linear-types/Language/Java/Inline/Internal/QQMarker/Names.hs b/src/linear-types/Language/Java/Inline/Internal/QQMarker/Names.hs new file mode 100644 --- /dev/null +++ b/src/linear-types/Language/Java/Inline/Internal/QQMarker/Names.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +module Language.Java.Inline.Internal.QQMarker.Names where + +import Data.Maybe +import GHC.Plugins +import qualified GhcPlugins.Extras +import Language.Java.Inline.Internal.QQMarker +import qualified Language.Java.Inline.Internal.QQMarker.Safe as Safe + +-- | Get the names of all markers used for java quasiquotations. +getQQMarkers :: CoreM [Name] +getQQMarkers = do + ma <- GhcPlugins.Extras.findTHName 'qqMarker + mb <- GhcPlugins.Extras.findTHName 'Safe.qqMarker + return $ catMaybes [ma, mb] diff --git a/src/linear-types/Language/Java/Inline/Internal/QQMarker/Safe.hs b/src/linear-types/Language/Java/Inline/Internal/QQMarker/Safe.hs new file mode 100644 --- /dev/null +++ b/src/linear-types/Language/Java/Inline/Internal/QQMarker/Safe.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.Java.Inline.Internal.QQMarker.Safe where + +import Data.Proxy +import GHC.Stack (HasCallStack, withFrozenCallStack) +import GHC.TypeLits (Nat, Symbol) +import qualified Language.Java.Safe as Safe + +-- | A function to indicate to the plugin the occurrence +-- of java quasiquotations +qqMarker + :: forall + k + (args_tys :: k) -- JType's of arguments + tyres -- JType of result + (input :: Symbol) -- input string of the quasiquoter + (mname :: Symbol) -- name of the method to generate + (antiqs :: Symbol) -- antiquoted variables as a comma-separated list + (line :: Nat) -- line number of the quasiquotation + args_tuple -- uncoerced argument types + b -- uncoerced result type + m. + ( tyres ~ Safe.Ty b + , Coercibles args_tuple args_tys + , Safe.Coercible b + , HasCallStack + ) + => Proxy input + -> Proxy mname + -> Proxy antiqs + -> Proxy line + -> args_tuple + #-> Proxy args_tys + -> (args_tuple #-> m b) + #-> m b +qqMarker = withFrozenCallStack $ + error + "A quasiquotation marker was not removed. Please, report this as a bug." + +class Coercibles xs (tys :: k) | xs -> tys +instance Coercibles () () +instance (ty ~ Safe.Ty x, Safe.Coercible x, Coercibles xs tys) + => Coercibles (x, xs) '(ty, tys) diff --git a/src/linear-types/Language/Java/Inline/Safe.hs b/src/linear-types/Language/Java/Inline/Safe.hs new file mode 100644 --- /dev/null +++ b/src/linear-types/Language/Java/Inline/Safe.hs @@ -0,0 +1,94 @@ +-- | = Inline Java quasiquotation with a linear interface +-- +-- See the +-- +-- for an introduction to quasiquotation. The quasiquoter exported in this +-- module allows embedding arbitrary Java expressions and blocks of statements +-- inside Haskell code. You can call any Java method and define arbitrary inline +-- code using Java syntax. No FFI required. +-- +-- Here is the same example as in "Language.Java", but with inline Java calls: +-- +-- @ +-- {-\# LANGUAGE DataKinds \#-} +-- {-\# LANGUAGE QuasiQuotes \#-} +-- module Object where +-- +-- import Language.Java.Inline.Safe +-- import Language.Java.Safe +-- +-- newtype Object = Object ('J' (''Class' "java.lang.Object")) +-- instance 'Coercible' Object +-- +-- clone :: Object ->. IO Object +-- clone obj = [java| $obj.clone() |] +-- +-- equals :: Object ->. Object ->. IO Bool +-- equals obj1 obj2 = [java| $obj1.equals($obj2) |] +-- +-- ... +-- @ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.Java.Inline.Safe + ( java + , Java.imports + , Java.loadJavaWrappers + ) where + +import qualified Control.Monad.Linear as Linear +import Foreign.JNI.Safe (liftPreludeIO) +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote +import qualified Language.Java.Inline.Internal as Java +import qualified Language.Java.Inline.Internal.QQMarker.Safe as Safe +import qualified Language.Java.Safe as Safe +import qualified Prelude.Linear as Linear + +-- | Java code quasiquoter. Example: +-- +-- @ +-- imports "javax.swing.JOptionPane" +-- +-- hello :: IO () +-- hello = do +-- message <- reflect ("Hello World!" :: Text) +-- [java| JOptionPane.showMessageDialog(null, $message) |] +-- @ +-- +-- A quasiquote is a snippet of Java code. The code is assumed to be a block +-- (sequence of statements) if the first non whitespace character is a @{@ +-- (curly brace) character. Otherwise it's parsed as an expression. Variables +-- with an initial @$@ (dollar) sign are allowed. They have a special meaning: +-- they stand for antiqotation variables (think of them as format specifiers in +-- printf format string). An antiquotation variable @$foo@ is well-scoped if +-- there exists a variable with the name @foo@ in the Haskell context of the +-- quasiquote, whose type is 'Coercible' to a Java primitive or reference type. +-- +java :: QuasiQuoter +java = Java.javaWithConfig Java.QQConfig + { Java.qqMarker = 'Safe.qqMarker + , Java.qqCallStatic = \qargs -> + let (args, tolist) = splitAt 2 qargs + in -- XXX: We need to explicitly use the linear ($) so GHC is satisfied + -- that the argument is going to be used linearly in the variadic + -- function. + TH.appE + (foldl + (flip TH.appE) + (TH.appsE (TH.varE 'Safe.callStatic : args)) + (map (\q -> [| (Linear.$ $q) |]) tolist) + ) + [| Safe.End |] + , Java.qqWrapMarker = \qExp -> + [| liftPreludeIO loadJavaWrappers Linear.>> $qExp |] + } diff --git a/src/no-linear-types/Language/Java/Inline/Internal/QQMarker/Names.hs b/src/no-linear-types/Language/Java/Inline/Internal/QQMarker/Names.hs new file mode 100644 --- /dev/null +++ b/src/no-linear-types/Language/Java/Inline/Internal/QQMarker/Names.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module Language.Java.Inline.Internal.QQMarker.Names where + +import Data.Maybe +import GhcPlugins +import qualified GhcPlugins.Extras +import Language.Java.Inline.Internal.QQMarker + +-- | Get the names of all markers used for java quasiquotations. +getQQMarkers :: CoreM [Name] +getQQMarkers = maybeToList <$> GhcPlugins.Extras.findTHName 'qqMarker diff --git a/tests/Language/Java/InlineSpec.hs b/tests/Language/Java/InlineSpec.hs deleted file mode 100644 --- a/tests/Language/Java/InlineSpec.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fplugin=Language.Java.Inline.Plugin #-} --- Test that inline-java produces code without warnings or errors. -{-# OPTIONS_GHC -dcore-lint -Wall -Werror #-} - -module Language.Java.InlineSpec(spec) where - -import Data.Int -import Foreign.JNI (JVMException) -import Foreign.JNI.Types (JObject, type (<>)) -import Language.Java -import Language.Java.Inline -import Test.Hspec - -type ObjectClass = 'Class "java.lang.Object" -type ListClass = 'Iface "java.util.List" - -type JJObject = JObject -type List a = J (ListClass <> '[a]) - -imports "java.util.*" - -spec :: Spec -spec = do - describe "Java quasiquoter" $ do - it "Can return ()" $ do - [java| { } |] :: IO () - - it "Evaluates simple expressions" $ do - [java| 1 + 1 |] `shouldReturn` (2 :: Int32) - - it "Evaluates simple blocks" $ do - [java| { - int x = 1; - int y = 2; - return x + y; - } |] `shouldReturn` (3 :: Int32) - - it "Supports antiquotation variables" $ do - let x = 1 :: Int32 - [java| $x + 1 |] `shouldReturn` (2 :: Int32) - - describe "Type synonyms" $ do - it "Supports top-level type synonym'ed antiquotation variables" $ do - obj <- [java| new Object() {} |] - let obj1 = obj :: JObject - _ :: JObject <- [java| $obj1 |] - return () - - it "Supports inner type synonym'ed antiquotation variables" $ do - obj <- [java| new Object() {} |] - let obj1 = obj :: J ObjectClass - _ :: J ObjectClass <- [java| $obj1 |] - return () - - it "Supports chained type synonym'ed antiquotation variables" $ do - obj <- [java| new Object() {} |] - let obj1 = obj :: JJObject - _ :: JJObject <- [java| $obj1 |] - return () - - it "Supports parameterized type synonyms" $ do - obj :: List ObjectClass <- [java| new ArrayList() |] - _ :: List ObjectClass <- [java| $obj |] - return () - - it "Supports multiple antiquotation variables" $ do - let foo = 1 :: Int32 - bar = 2 :: Int32 - [java| $foo + $bar |] `shouldReturn` (3 :: Int32) - - it "Supports repeated antiquotation variables" $ do - obj :: JObject <- [java| new Object() {} |] - ([java| $obj.equals($obj) |] >>= reify) `shouldReturn` True - - it "Supports antiquotation variables in blocks" $ do - let z = 1 :: Int32 - [java| { return $z + 1; } |] `shouldReturn` (2 :: Int32) - - it "Supports anonymous classes" $ do - _ :: JObject <- [java| new Object() {} |] - return () - - it "Supports multiple anonymous classes" $ do - [java| new Object() {}.equals(new Object() {}) |] `shouldReturn` False - - it "Supports using antiquotation variables in inner classes" $ do - let foo = 1 :: Int32 - [java| { class Foo { int f() { return $foo; } }; } |] :: IO () - - it "Supports import declarations" $ do - -- Arrays comes from the java.util package. - _ <- [java| Arrays.asList().toArray() |] :: IO JObjectArray - return () - - it "Supports anonymous functions" $ do - [java| { - List xs = Arrays.asList(1, 2); - Collections.sort(xs, (a, b) -> b.compareTo(a)); - return xs.get(0); - } |] `shouldReturn` (2 :: Int32) - - it "Can be used inside brackets" $ do - $([| let _x = 1 :: Int32 -- Named _x to avoid spurious "unused" warning - in (+1) <$> [java| $_x |] - |]) `shouldReturn` (2 :: Int32) - - it "Can throw checked exceptions" $ do - ([java| { throw new InterruptedException(); } |] :: IO ()) - `shouldThrow` \(_ :: JVMException) -> True - - it "Type-checks generics" $ do - obj :: List ('Class "java.lang.String") <- - [java| new ArrayList() |] - _ :: List ('Class "java.lang.String") <- [java| $obj |] - return () - - it "Can access inner classes" $ do - st :: J ('Class "java.lang.Thread$State") <- - [java| Thread.State.NEW |] - [java| $st == Thread.State.NEW |] `shouldReturn` True diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Main where - -import Language.Java (withJVM) -import qualified Spec -import Test.Hspec - -main :: IO () -main = withJVM [] $ hspec Spec.spec diff --git a/tests/Spec.hs b/tests/Spec.hs deleted file mode 100644 --- a/tests/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/tests/common/Language/Java/InlineSpec.hs b/tests/common/Language/Java/InlineSpec.hs new file mode 100644 --- /dev/null +++ b/tests/common/Language/Java/InlineSpec.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +-- Test that inline-java produces code without warnings or errors. +{-# OPTIONS_GHC -dcore-lint -Wall -Werror #-} + +module Language.Java.InlineSpec(spec) where + +import Data.Char +import Data.Int +import qualified Data.Text as Text +import qualified Data.Vector.Storable as Vector +import Data.Vector.Storable.Mutable (IOVector) +import Foreign.JNI (JVMException) +import Language.Java +import Language.Java.Inline +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.Unicode + +type ObjectClass = 'Class "java.lang.Object" +type ListClass = 'Iface "java.util.List" + +type JJObject = JObject +type List a = J (ListClass <> '[a]) + +imports "java.util.*" + +spec :: Spec +spec = do + describe "Java quasiquoter" $ do + it "Can return ()" $ do + [java| { } |] :: IO () + + it "Evaluates simple expressions" $ do + [java| 1 + 1 |] `shouldReturn` (2 :: Int32) + + it "Evaluates simple blocks" $ do + [java| { + int x = 1; + int y = 2; + return x + y; + } |] `shouldReturn` (3 :: Int32) + + it "Supports antiquotation variables" $ do + let x = 1 :: Int32 + [java| $x + 1 |] `shouldReturn` (2 :: Int32) + + describe "Type synonyms" $ do + it "Supports top-level type synonym'ed antiquotation variables" $ do + obj <- [java| new Object() {} |] + let obj1 = obj :: JObject + _ :: JObject <- [java| $obj1 |] + return () + + it "Supports inner type synonym'ed antiquotation variables" $ do + obj <- [java| new Object() {} |] + let obj1 = obj :: J ObjectClass + _ :: J ObjectClass <- [java| $obj1 |] + return () + + it "Supports chained type synonym'ed antiquotation variables" $ do + obj <- [java| new Object() {} |] + let obj1 = obj :: JJObject + _ :: JJObject <- [java| $obj1 |] + return () + + it "Supports parameterized type synonyms" $ do + obj :: List ObjectClass <- [java| new ArrayList() |] + _ :: List ObjectClass <- [java| $obj |] + return () + + it "Supports multiple antiquotation variables" $ do + let foo = 1 :: Int32 + bar = 2 :: Int32 + [java| $foo + $bar |] `shouldReturn` (3 :: Int32) + + it "Supports repeated antiquotation variables" $ do + obj :: JObject <- [java| new Object() {} |] + ([java| $obj.equals($obj) |] >>= reify) `shouldReturn` True + + it "Supports antiquotation variables in blocks" $ do + let z = 1 :: Int32 + [java| { return $z + 1; } |] `shouldReturn` (2 :: Int32) + + it "Supports anonymous classes" $ do + _ :: JObject <- [java| new Object() {} |] + return () + + it "Supports multiple anonymous classes" $ do + [java| new Object() {}.equals(new Object() {}) |] `shouldReturn` False + + it "Supports using antiquotation variables in inner classes" $ do + let foo = 1 :: Int32 + [java| { class Foo { int f() { return $foo; } }; } |] :: IO () + + it "Supports import declarations" $ do + -- Arrays comes from the java.util package. + _ <- [java| Arrays.asList().toArray() |] :: IO JObjectArray + return () + + it "Supports anonymous functions" $ do + [java| { + List xs = Arrays.asList(1, 2); + Collections.sort(xs, (a, b) -> b.compareTo(a)); + return xs.get(0); + } |] `shouldReturn` (2 :: Int32) + + it "Can be used inside brackets" $ do + $([| let _x = 1 :: Int32 -- Named _x to avoid spurious "unused" warning + in (+1) <$> [java| $_x |] + |]) `shouldReturn` (2 :: Int32) + + it "Can throw checked exceptions" $ do + ([java| { throw new InterruptedException(); } |] :: IO ()) + `shouldThrow` \(_ :: JVMException) -> True + + it "Type-checks generics" $ do + obj :: List ('Class "java.lang.String") <- + [java| new ArrayList() |] + _ :: List ('Class "java.lang.String") <- [java| $obj |] + return () + + it "Can access inner classes" $ do + st :: J ('Class "java.lang.Thread$State") <- + [java| Thread.State.NEW |] + [java| $st == Thread.State.NEW |] `shouldReturn` True + + it "Supports modified utf-8 encoding from Haskell to Java" $ + withLocalRef (reflect ("a\NULb" :: Text.Text)) $ \jString -> + [java| "a\0b".equals($jString) |] `shouldReturn` True + + it "Supports modified utf-8 encoding from Java to Haskell" $ do + withLocalRef [java| "a\0b" |] reify `shouldReturn` ("a\NULb" :: Text.Text) + + prop "Processes Unicode code points as the JVM does" $ do + \u -> ioProperty $ do + let chars :: [Char] = fromUnicode u + let text = Text.pack chars + codePoints :: IOVector Int32 <- Vector.thaw $ Vector.fromList $ map (fromIntegral . ord) chars + withLocalRef (reflect codePoints) $ \jPoints -> do + jString <- [java| new String($jPoints, 0, $jPoints.length) |] + jText <- reify jString + return $ jText === text diff --git a/tests/common/Main.hs b/tests/common/Main.hs new file mode 100644 --- /dev/null +++ b/tests/common/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Control.Concurrent (runInBoundThread) +import Foreign.JNI +import qualified SafeSpec +import qualified Spec +import Test.Hspec + +main :: IO () +main = withJVM [] $ hspec $ + around_ (runInBoundThread . runInAttachedThread) $ do + Spec.spec + SafeSpec.spec diff --git a/tests/common/Spec.hs b/tests/common/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/common/Spec.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -F -pgmF HSPEC_DISCOVER -optF --module-name=Spec #-} diff --git a/tests/linear-types/Language/Java/Inline/SafeSpec.hs b/tests/linear-types/Language/Java/Inline/SafeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/linear-types/Language/Java/Inline/SafeSpec.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +-- Test that inline-java produces code without warnings or errors. +-- +-- -O0 is necessary to workaround a bug in ghc-8.9.20190613 +-- https://github.com/tweag/ghc/issues/384 +{-# OPTIONS_GHC -dcore-lint -Wall -Werror -Wno-name-shadowing -O0 #-} + +module Language.Java.Inline.SafeSpec(spec) where + +import qualified Control.Monad.Linear as Linear +import Data.Int +import Foreign.JNI (JVMException) +import Foreign.JNI.Safe +import Language.Java.Safe +import Language.Java.Inline.Safe +import Prelude hiding ((>>=), (>>)) +import Test.Hspec + +type ObjectClass = 'Class "java.lang.Object" +type ListClass = 'Iface "java.util.List" + +type JJObject = JObject +type List a = J (ListClass <> '[a]) + +imports "java.util.*" + +spec :: Spec +spec = do + describe "Linear Java quasiquoter" $ do + it "Can return ()" $ + withLocalFrame_ [java| { } |] + + it "Evaluates simple expressions" $ + withLocalFrame [java| 1 + 1 |] `shouldReturn` (2 :: Int32) + + it "Evaluates simple blocks" $ + withLocalFrame [java| { + int x = 1; + int y = 2; + return x + y; + } |] `shouldReturn` (3 :: Int32) + + it "Supports antiquotation variables" $ do + let x = 1 :: Int32 + withLocalFrame [java| $x + 1 |] `shouldReturn` (2 :: Int32) + + describe "Type synonyms" $ do + it "Supports top-level type synonym'ed antiquotation variables" $ + withLocalFrame_ $ Linear.do + obj :: JObject <- [java| new Object() {} |] + jobj1 <- [java| $obj |] + deleteLocalRef (jobj1 :: JObject) + + it "Supports inner type synonym'ed antiquotation variables" $ + withLocalFrame_ $ Linear.do + obj :: J ObjectClass <- [java| new Object() {} |] + obj1 :: J ObjectClass <- [java| $obj |] + deleteLocalRef obj1 + + it "Supports chained type synonym'ed antiquotation variables" $ + withLocalFrame_ $ Linear.do + obj :: JJObject <- [java| new Object() {} |] + obj1 :: JJObject <- [java| $obj |] + deleteLocalRef obj1 + + it "Supports parameterized type synonyms" $ + withLocalFrame_ $ Linear.do + obj :: List ObjectClass <- [java| new ArrayList() |] + obj1 :: List ObjectClass <- [java| $obj |] + deleteLocalRef obj1 + + it "Supports multiple antiquotation variables" $ do + let foo = 1 :: Int32 + bar = 2 :: Int32 + withLocalFrame [java| $foo + $bar |] `shouldReturn` (3 :: Int32) + + it "Supports repeated antiquotation variables" $ + withLocalFrame (Linear.do + obj :: JObject <- [java| new Object() {} |] + [java| $obj.equals($obj) |] Linear.>>= reify_ + ) `shouldReturn` True + + it "Supports antiquotation variables in blocks" $ do + let z = 1 :: Int32 + withLocalFrame [java| { return $z + 1; } |] + `shouldReturn` (2 :: Int32) + + it "Supports anonymous classes" $ + withLocalFrame_ $ Linear.do + obj :: JObject <- [java| new Object() {} |] + deleteLocalRef obj + + it "Supports multiple anonymous classes" $ + withLocalFrame [java| new Object() {}.equals(new Object() {}) |] + `shouldReturn` False + + it "Supports using antiquotation variables in inner classes" $ do + let foo = 1 :: Int32 + withLocalFrame_ + [java| { class Foo { int f() { return $foo; } }; } |] :: IO () + + it "Supports import declarations" $ + -- Arrays comes from the java.util package. + withLocalFrame_ $ Linear.do + obj :: JObjectArray <- [java| Arrays.asList().toArray() |] + deleteLocalRef obj + + it "Supports anonymous functions" $ + withLocalFrame [java| { + List xs = Arrays.asList(1, 2); + Collections.sort(xs, (a, b) -> b.compareTo(a)); + return xs.get(0); + } |] `shouldReturn` (2 :: Int32) + + it "Can be used inside brackets" $ + $([| let _x = 1 :: Int32 -- Named _x to avoid spurious "unused" warning + in (+1) Prelude.<$> withLocalFrame [java| $_x |] + |]) `shouldReturn` (2 :: Int32) + + it "Can throw checked exceptions" $ + withLocalFrame_ [java| { throw new InterruptedException(); } |] + `shouldThrow` \(_ :: JVMException) -> True + + it "Type-checks generics" $ + withLocalFrame_ $ Linear.do + obj :: List ('Class "java.lang.String") <- [java| new ArrayList() |] + obj1 :: List ('Class "java.lang.String") <- [java| $obj |] + deleteLocalRef obj1 + + it "Can access inner classes" $ + (withLocalFrame $ Linear.do + st :: J ('Class "java.lang.Thread$State") <- [java| Thread.State.NEW |] + [java| $st == Thread.State.NEW |] + ) `shouldReturn` True diff --git a/tests/linear-types/SafeSpec.hs b/tests/linear-types/SafeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/linear-types/SafeSpec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=SafeSpec #-} diff --git a/tests/no-linear-types/SafeSpec.hs b/tests/no-linear-types/SafeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/no-linear-types/SafeSpec.hs @@ -0,0 +1,6 @@ +module SafeSpec(spec) where + +import Test.Hspec + +spec :: Spec +spec = return ()