inline-java 0.8.4 → 0.9.0
raw patch · 32 files changed
+1849/−1103 lines, 32 filesdep +criteriondep +deepseqdep +linear-basedep ~basedep ~ghcdep ~jni
Dependencies added: criterion, deepseq, linear-base, singletons
Dependency ranges changed: base, ghc, jni, jvm
Files
- CHANGELOG.md +19/−0
- README.md +35/−9
- benchmarks/micro/Main.hs +139/−0
- inline-java.cabal +56/−8
- src/Language/Java/Inline.hs +0/−206
- src/Language/Java/Inline/Cabal.hs +0/−141
- src/Language/Java/Inline/Magic.hsc +0/−115
- src/Language/Java/Inline/Plugin.hs +0/−489
- src/common/Language/Java/Inline.hs +5/−0
- src/common/Language/Java/Inline/Cabal.hs +140/−0
- src/common/Language/Java/Inline/Internal.hs +206/−0
- src/common/Language/Java/Inline/Internal/Magic.hsc +81/−0
- src/common/Language/Java/Inline/Internal/QQMarker.hs +53/−0
- src/common/Language/Java/Inline/Plugin.hs +459/−0
- src/common/Language/Java/Inline/Unsafe.hs +90/−0
- src/ghc-8.10/FastString/Extras.hs +3/−0
- src/ghc-8.10/GhcPlugins/Extras.hs +49/−0
- src/ghc-8.11/FastString/Extras.hs +3/−0
- src/ghc-8.11/GhcPlugins/Extras.hs +51/−0
- src/linear-types/Language/Java/Inline/Internal/QQMarker/Names.hs +15/−0
- src/linear-types/Language/Java/Inline/Internal/QQMarker/Safe.hs +53/−0
- src/linear-types/Language/Java/Inline/Safe.hs +94/−0
- src/no-linear-types/Language/Java/Inline/Internal/QQMarker/Names.hs +11/−0
- tests/Language/Java/InlineSpec.hs +0/−126
- tests/Main.hs +0/−8
- tests/Spec.hs +0/−1
- tests/common/Language/Java/InlineSpec.hs +124/−0
- tests/common/Main.hs +11/−0
- tests/common/Spec.hs +2/−0
- tests/linear-types/Language/Java/Inline/SafeSpec.hs +143/−0
- tests/linear-types/SafeSpec.hs +1/−0
- tests/no-linear-types/SafeSpec.hs +6/−0
CHANGELOG.md view
@@ -4,6 +4,25 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/). +## Next++### Added+### Removed+### Changed++## [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
README.md view
@@ -1,8 +1,7 @@ # inline-java: Call any JVM function from Haskell [](https://circleci.com/gh/tweag/inline-java)--**NOTE 1: you'll need GHC >= 8.0.2 to compile and use this package.**+[](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,7 +71,38 @@ [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-interface] 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.++[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 ## Debugging
+ benchmarks/micro/Main.hs view
@@ -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<String,String,String>) $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 ]
inline-java.cabal view
@@ -1,5 +1,5 @@ name: inline-java-version: 0.8.4+version: 0.9.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.7 && <0.8,+ jvm >=0.5 && <0.6, 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:@@ -68,3 +92,27 @@ inline-java, text default-language: Haskell2010+ 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
− src/Language/Java/Inline.hs
@@ -1,206 +0,0 @@--- | = Inline Java quasiquotation------ See the--- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell-quasi-quotation GHC manual>--- 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)) |]
− src/Language/Java/Inline/Cabal.hs
@@ -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 <http://search.maven.org/ Maven Central>.------ You can set the @CLASSPATH@ manually, or extract one from an external build--- system configuration. Currently supported build systems:------ * <https://gradle.org/ Gradle>--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---- "<pkgname>.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- }
− src/Language/Java/Inline/Magic.hsc
@@ -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)
− src/Language/Java/Inline/Plugin.hs
@@ -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__<pkgname>_<modname> {--- > 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__<pkg>_<mod>" "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__<pkg>_<mod>" "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
+ src/common/Language/Java/Inline.hs view
@@ -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
+ src/common/Language/Java/Inline/Cabal.hs view
@@ -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 <http://search.maven.org/ Maven Central>.+--+-- You can set the @CLASSPATH@ manually, or extract one from an external build+-- system configuration. Currently supported build systems:+--+-- * <https://gradle.org/ Gradle>++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++-- "<pkgname>.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+ }
+ src/common/Language/Java/Inline/Internal.hs view
@@ -0,0 +1,206 @@+-- | = Inline Java quasiquotation+--+-- See the+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell-quasi-quotation GHC manual>+-- 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'+ )+ )+ |]
+ src/common/Language/Java/Inline/Internal/Magic.hsc view
@@ -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
+ src/common/Language/Java/Inline/Internal/QQMarker.hs view
@@ -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)
+ src/common/Language/Java/Inline/Plugin.hs view
@@ -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__<pkgname>_<modname> {+-- > 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__<pkg>_<mod>" "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__<pkg>_<mod>" "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); }"+ ]
+ src/common/Language/Java/Inline/Unsafe.hs view
@@ -0,0 +1,90 @@+-- | = Inline Java quasiquotation+--+-- See the+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell-quasi-quotation GHC manual>+-- 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 |]+ }
+ src/ghc-8.10/FastString/Extras.hs view
@@ -0,0 +1,3 @@+module FastString.Extras(bytesFS) where++import FastString
+ src/ghc-8.10/GhcPlugins/Extras.hs view
@@ -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
+ src/ghc-8.11/FastString/Extras.hs view
@@ -0,0 +1,3 @@+module FastString.Extras(bytesFS) where++import GHC.Data.FastString
+ src/ghc-8.11/GhcPlugins/Extras.hs view
@@ -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
+ src/linear-types/Language/Java/Inline/Internal/QQMarker/Names.hs view
@@ -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]
+ src/linear-types/Language/Java/Inline/Internal/QQMarker/Safe.hs view
@@ -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)
+ src/linear-types/Language/Java/Inline/Safe.hs view
@@ -0,0 +1,94 @@+-- | = Inline Java quasiquotation with a linear interface+--+-- See the+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell-quasi-quotation GHC manual>+-- 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 |]+ }
+ src/no-linear-types/Language/Java/Inline/Internal/QQMarker/Names.hs view
@@ -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
− tests/Language/Java/InlineSpec.hs
@@ -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<Integer> 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<String>() |]- _ :: 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
− tests/Main.hs
@@ -1,8 +0,0 @@-module Main where--import Language.Java (withJVM)-import qualified Spec-import Test.Hspec--main :: IO ()-main = withJVM [] $ hspec Spec.spec
− tests/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ tests/common/Language/Java/InlineSpec.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# 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.Int+import Foreign.JNI (JVMException)+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<Integer> 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<String>() |]+ _ :: 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
+ tests/common/Main.hs view
@@ -0,0 +1,11 @@+module Main where++import Language.Java (withJVM)+import qualified SafeSpec+import qualified Spec+import Test.Hspec++main :: IO ()+main = withJVM [] $ hspec $ do+ Spec.spec+ SafeSpec.spec
+ tests/common/Spec.hs view
@@ -0,0 +1,2 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -F -pgmF HSPEC_DISCOVER -optF --module-name=Spec #-}
+ tests/linear-types/Language/Java/Inline/SafeSpec.hs view
@@ -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<Integer> 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<String>() |]+ 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
+ tests/linear-types/SafeSpec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=SafeSpec #-}
+ tests/no-linear-types/SafeSpec.hs view
@@ -0,0 +1,6 @@+module SafeSpec(spec) where++import Test.Hspec++spec :: Spec+spec = return ()