inline-java 0.6.5 → 0.7.0
raw patch · 9 files changed
+879/−321 lines, 9 filesdep +ghcdep +mtldep −binarydep −containersdep −distributed-closuredep ~basedep ~bytestringdep ~jni
Dependencies added: ghc, mtl
Dependencies removed: binary, containers, distributed-closure, ghc-heap-view, inline-c, singletons, syb, thread-local-storage, vector
Dependency ranges changed: base, bytestring, jni, jvm
Files
- CHANGELOG.md +34/−0
- README.md +26/−15
- cbits/bctable.c +17/−0
- cbits/bctable.h +32/−0
- inline-java.cabal +14/−15
- src/Language/Java/Inline.hs +78/−276
- src/Language/Java/Inline/Magic.hsc +115/−0
- src/Language/Java/Inline/Plugin.hs +478/−0
- tests/Language/Java/InlineSpec.hs +85/−15
CHANGELOG.md view
@@ -4,6 +4,40 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/). +## Next release++## [0.7.0] - 2017-08-31++### Added++* Plugin option to dump the generated Java to the console or a file.+* Partial support for inner classes. Antiquoted variables and+ quasiquotation results can refer to inner classes now.++### Changed++* Use a compiler plugin to build the bytecode table and to generate+ Java code. We no longer need static pointers to find the bytecode+ at runtime, and we can check at build-time that values are+ marshaled between matching types in Java and Haskell when using+ antiquated variables or the result of quasiquotations. Also, now+ java quasiquotes work inside Template Haskell brackets ([| ... |]).+* Use only the lexer in `language-java`. This defers most parsing+ errors to the `javac` compiler which produces better error+ messages and might support newer syntactic constructs like+ anonymous functions.+* Java checked exceptions are now allowed in java quasiquotes.++### Fixed++* Gradle hooks now produce a correct build-time classpath.++## [0.6.5] - 2017-04-13++## Added++* Exposed loadJavaWrappers.+ ## [0.6.4] - 2017-04-09 ### Fixed
README.md view
@@ -1,13 +1,12 @@ # inline-java: Call any JVM function from Haskell -[](https://app.wercker.com/project/byKey/dfeba78838cc77d4c5e06eedc5c0833d)+[](https://circleci.com/gh/tweag/inline-java) -**NOTE: you'll need GHC >= 8.0.2 to compile and use this package. Use**-```-stack --nix build-```-**ahead of a new GHC release to build using GHC 8.0.2-rc2.**+**NOTE 1: you'll need GHC >= 8.0.2 to compile and use this package.** +**NOTE 2: you'll need Stack HEAD (future v1.6) to compile with GHC >=+8.2.1. It is recommended to stick to GHC-8.0.2 for now.**+ The Haskell standard includes a native foreign function interface (FFI). Using it can be a bit involved and only C support is implemented in GHC. `inline-java` lets you call any JVM function@@ -28,20 +27,19 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fplugin=Language.Java.Inline.Plugin #-} module Main where -import Data.Int import Data.Text (Text) import Language.Java import Language.Java.Inline -main :: IO Int32+main :: IO () main = withJVM [] $ do- -- Extra type annotation workaround for current GHC HEAD.- message :: J ('Class "java.lang.String") <- reflect ("Hello World!" :: Text)- [java| { javax.swing.JOptionPane.showMessageDialog(null, $message);- return 0; } |]+ message <- reflect ("Hello World!" :: Text)+ [java| {+ javax.swing.JOptionPane.showMessageDialog(null, $message);+ } |] ``` ## Building it@@ -81,6 +79,16 @@ [nix]: http://nixos.org/nix [osx-java-se]: https://support.apple.com/kb/dl1572?locale=fr_FR +## Debugging++The generated java output can be dumped to stderr by passing to GHC+```+-fplugin-opt=Language.Java.Inline.Plugin:dump-java+```++If `-ddump-to-file` is in effect (as when using `stack`), the java code+is dumped to `<module>.dump-java` instead.+ ## License Copyright (c) 2015-2016 EURL Tweag.@@ -90,9 +98,12 @@ inline-java is free software, and may be redistributed under the terms specified in the [LICENSE](LICENSE) file. -## About+## Sponsors -+ +[](http://tweag.io)+ +[](http://leapyear.io) inline-java is maintained by [Tweag I/O](http://tweag.io/).
+ cbits/bctable.c view
@@ -0,0 +1,17 @@+#include "bctable.h"+#include <stdlib.h>++struct inline_java_pack *inline_java_new_pack(+ struct inline_java_pack *next,+ struct inline_java_dot_class classes[],+ size_t size)+{+ struct inline_java_pack *new = malloc(sizeof(struct inline_java_pack));+ new->next = next;+ new->size = size;+ new->classes = classes;++ return new;+}++struct inline_java_pack *inline_java_bctable;
+ cbits/bctable.h view
@@ -0,0 +1,32 @@+#include <stdlib.h>++/** List of JVM class bytecode definitions. The content corresponds to+ * that of a .class file. */+struct inline_java_dot_class {+ char *name;+ size_t bytecode_sz;+ unsigned char *bytecode;+};+++/** A set of .class files contents. */+struct inline_java_pack {+ struct inline_java_pack *next;+ struct inline_java_dot_class *classes;+ size_t size;+};++/** Smart constructor for class file packs. */+struct inline_java_pack *inline_java_new_pack(+ struct inline_java_pack *next,+ struct inline_java_dot_class classes[],+ size_t size);++/** Global list of class files.+ *+ * All modules insert the bytecode of the classes they need when they+ * are loaded.+ *+ * inline-java reads this table to load the classes in loadJavaWrappers.+ */+extern struct inline_java_pack *inline_java_bctable;
inline-java.cabal view
@@ -1,5 +1,5 @@ name: inline-java-version: 0.6.5+version: 0.7.0 synopsis: Java interop via inline Java code in Haskell modules. description: Please see README.md. homepage: http://github.com/tweag/inline-java#readme@@ -23,32 +23,33 @@ library hs-source-dirs: src+ c-sources: cbits/bctable.c+ cc-options: -std=c99 -Wall -Werror+ include-dirs: cbits/+ includes: bctable.h+ install-includes: bctable.h exposed-modules: Language.Java.Inline Language.Java.Inline.Cabal+ Language.Java.Inline.Plugin+ other-modules:+ Language.Java.Inline.Magic build-depends: -- Can't build at all with GHC < 8.0.2. base > 4.9.0.0 && < 5,- binary >=0.7, bytestring >=0.10, Cabal >= 1.24.2,- containers >=0.5, directory >=1.2,- distributed-closure >=0.3, filepath >= 1,- ghc-heap-view >= 0.5,- inline-c >=0.5,- jni >= 0.3,- jvm >= 0.2,+ ghc >= 8.0.2 && < 8.3,+ jni >= 0.4,+ jvm >= 0.3, language-java >= 0.2,+ mtl >= 2.2.1, process >= 1.2,- singletons >= 2.0,- syb >= 0.6, text >=1.2, template-haskell >= 2.10,- temporary >= 1.2,- thread-local-storage >=0.1,- vector >=0.11+ temporary >= 1.2 default-language: Haskell2010 test-suite spec@@ -61,11 +62,9 @@ Language.Java.InlineSpec build-depends: base,- bytestring, jni, jvm, hspec, inline-java,- singletons, text default-language: Haskell2010
src/Language/Java/Inline.hs view
@@ -12,6 +12,7 @@ -- @ -- {-\# LANGUAGE DataKinds \#-} -- {-\# LANGUAGE QuasiQuotes \#-}+-- {-\# OPTIONS_GHC -fplugin=Language.Java.Inline.Plugin \#-} -- module Object where -- -- import Language.Java as J@@ -38,71 +39,56 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StaticPointers #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Language.Java.Inline ( java+ , imports , loadJavaWrappers ) where -import Control.Monad (forM_, unless)-import qualified Data.ByteString.Char8 as BS-import Data.Char (isAlphaNum)-import Data.Generics (everything, mkQ)-import Data.List (intercalate, isPrefixOf, isSuffixOf, nub)-import Data.Maybe (fromJust)-import Data.Singletons (SomeSing(..))+import Data.Data+import Data.List (isPrefixOf, intercalate, isSuffixOf, nub) import Data.String (fromString)-import Data.Traversable (forM) import Foreign.JNI (defineClass)-import qualified Foreign.JNI.String as JNI-import GHC.Exts (Any)-import qualified GHC.HeapView as HeapView-import GHC.StaticPtr- ( StaticPtr- , deRefStaticPtr- , staticPtrKeys- , unsafeLookupStaticPtr- ) import Language.Java-import qualified Language.Java.Parser as Java-import qualified Language.Java.Pretty as Java-import qualified Language.Java.Syntax as 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.FilePath ((</>), (<.>))-import System.Directory (listDirectory)-import System.IO.Temp (withSystemTempDirectory) import System.IO.Unsafe (unsafePerformIO)-import System.Process (callProcess) -- 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 register a module finalizer that captures the local scope. At the--- end of the module, when all type checking is done, our finalizer will be run.--- 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.+-- 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 the static pointer table (SPT). That way at runtime we can enumerate--- the bytecode blobs registered in the SPT, and load them into the JVM one by--- one.+-- 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 ()@@ -120,10 +106,6 @@ -- 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. ----- __NOTE:__ In GHC 8.0.2 and earlier, due to--- <https://ghc.haskell.org/trac/ghc/ticket/12778 #12778>, a quasiquote must--- always return a boxed value (i.e. an object, not void or a primitive type).--- This limitation may be lifted in the future. java :: QuasiQuoter java = QuasiQuoter { quoteExp = \txt -> blockOrExpQQ txt@@ -132,169 +114,43 @@ , quoteDec = error "Language.Java.Inline: quoteDec" } -antis :: Java.Block -> [String]-antis = nub . everything (++) (mkQ [] (\case Java.Name (Java.Ident ('$':av):_) -> [av]; _ -> []))--toJavaType :: Sing (a :: JType) -> Java.Type-toJavaType ty = case Java.parser Java.ttype (pretty ty) of- Left err -> error $ "toJavaType: " ++ show err- Right x -> x- where- pretty :: Sing (a :: JType) -> String- pretty (SClass sym) = sym- pretty (SIface sym) = sym- pretty (SPrim sym) = sym- pretty (SArray ty1) = pretty ty1 ++ "[]"- pretty (SGeneric _ty1 _tys) = error "toJavaType(Generic): Unimplemented."- pretty SVoid = "void"--abstract- :: Java.Ident- -> Maybe Java.Type- -> [(Java.Ident, Java.Type)]- -> Java.Block- -> Java.MemberDecl-abstract mname retty vtys block =- Java.MethodDecl [Java.Public, Java.Static] [] retty mname params [] body- where- body = Java.MethodBody (Just block)- params = [ Java.FormalParam [] ty False (Java.VarId v) | (v, ty) <- vtys ]---- | Decode a TH 'Type' into a 'JType'. So named because it's morally the--- inverse of 'Language.Haskell.TH.Syntax.lift'.-unliftJType :: TH.Type -> Q (SomeSing JType)-unliftJType (TH.AppT (TH.PromotedT nm) (TH.LitT (TH.StrTyLit sym)))- | nm == 'Class = return $ SomeSing $ SClass (fromString sym)- | nm == 'Iface = return $ SomeSing $ SIface (fromString sym)- | nm == 'Prim = return $ SomeSing $ SPrim (fromString sym)-unliftJType (TH.AppT (TH.PromotedT nm) ty)- | nm == 'Array = unliftJType ty >>= \case SomeSing jty -> return $ SomeSing (SArray jty)-unliftJType (TH.AppT (TH.AppT (TH.PromotedT _nm) _ty) _tys) =- error "unliftJType (Generic): Unimplemented."--- Sometimes TH uses ConT for PromotedT. Pretend it's always PromotedT.-unliftJType (TH.AppT (TH.ConT nm) ty) =- unliftJType $ TH.AppT (TH.PromotedT nm) ty-unliftJType (TH.PromotedT nm)- | nm == 'Void = return $ SomeSing SVoid-unliftJType ty = fail $ "unliftJType: cannot unlift " ++ show (TH.ppr ty)--getValueName :: String -> Q TH.Name-getValueName v =- TH.lookupValueName v >>= \case- Nothing -> fail $ "Identifier not in scope: " ++ v- Just name -> return name--makeCompilationUnit- :: Java.Name- -> [Java.ImportDecl]- -> Java.ClassDecl- -> Java.CompilationUnit-makeCompilationUnit pkgname imports cls =- Java.CompilationUnit (Just (Java.PackageDecl pkgname)) imports [Java.ClassTypeDecl cls]--makeClass :: Java.Ident -> [Java.MemberDecl] -> Java.ClassDecl-makeClass cname methods =- Java.ClassDecl- []- cname- []- Nothing- []- (Java.ClassBody- (map Java.MemberDecl methods))--emit :: FilePath -> Java.CompilationUnit -> IO ()-emit file cdecl = writeFile file (Java.prettyPrint cdecl)- -- | Private newtype to key the TH state.-data FinalizerState = FinalizerState- { finalizerCount :: Int- , wrappers :: [Java.MemberDecl]- }+newtype IJState = IJState { methodCount :: Integer } -initialFinalizerState :: FinalizerState-initialFinalizerState = FinalizerState 0 []+initialIJState :: IJState+initialIJState = IJState 0 -getFinalizerState :: Q FinalizerState-getFinalizerState = TH.getQ >>= \case+getIJState :: Q IJState+getIJState = TH.getQ >>= \case Nothing -> do- TH.putQ initialFinalizerState- return initialFinalizerState+ TH.putQ initialIJState+ return initialIJState Just st -> return st -setFinalizerState :: FinalizerState -> Q ()-setFinalizerState = TH.putQ--incrementFinalizerCount :: Q ()-incrementFinalizerCount =- getFinalizerState >>= \FinalizerState{..} ->- setFinalizerState FinalizerState{finalizerCount = finalizerCount + 1, ..}--decrementFinalizerCount :: Q ()-decrementFinalizerCount =- getFinalizerState >>= \FinalizerState{..} ->- setFinalizerState FinalizerState{finalizerCount = max 0 (finalizerCount - 1), ..}--isLastFinalizer :: Q Bool-isLastFinalizer = getFinalizerState >>= \FinalizerState{..} -> return $ finalizerCount == 0--pushWrapper :: Java.MemberDecl -> Q ()-pushWrapper w =- getFinalizerState >>= \FinalizerState{..} ->- setFinalizerState FinalizerState{wrappers = w:wrappers, ..}--pushWrapperGen :: Q Java.MemberDecl -> Q ()-pushWrapperGen gen = do- incrementFinalizerCount- TH.addModFinalizer $ do- decrementFinalizerCount- pushWrapper =<< gen- isLastFinalizer >>= \case- True -> do- FinalizerState{wrappers} <- getFinalizerState- thismod <- TH.thisModule- unless (null wrappers) $ do- embedAsBytecode "io/tweag/inlinejava" (mangle thismod) $- makeCompilationUnit pkgname [] $- makeClass (Java.Ident (mangle thismod)) wrappers- False -> return ()- where- pkgname = Java.Name $ map Java.Ident ["io", "tweag", "inlinejava"]---- | A wrapper for class bytecode.-data DotClass = DotClass- { className :: JNI.String- , classBytecode :: BS.ByteString- }+setIJState :: IJState -> Q ()+setIJState = TH.putQ -instance TH.Lift DotClass where- lift DotClass{..} =- [| DotClass- (JNI.fromChars $(TH.lift (JNI.toChars className)))- (BS.pack $(TH.lift (BS.unpack classBytecode)))- |]+-- | 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 [] -embedAsBytecode :: String -> String -> Java.CompilationUnit -> Q ()-embedAsBytecode pkg name unit = do- dcs <- TH.runIO $ do- withSystemTempDirectory "inlinejava" $ \dir -> do- let src = dir </> name <.> "java"- emit src 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 = pkg ++ "/" ++ takeWhile (/= '.') classFile- return $ DotClass (JNI.fromChars klass) bcode- forM_ (zip dcs [(0 :: Int)..]) $ \(dc, i) -> do- ptr <- TH.newName $ "_inlinejava__bytecode" ++ show i- TH.addTopDecls =<<- sequence- [ TH.sigD ptr [t| StaticPtr DotClass |]- , TH.valD (TH.varP ptr) (TH.normalB [| static $(TH.lift dc) |]) []- ]+-- | 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.@@ -302,26 +158,18 @@ loadJavaWrappers = doit `seq` return () where {-# NOINLINE doit #-}- doit = unsafePerformIO $ do- keys <- staticPtrKeys- loader :: J ('Class "java.lang.ClassLoader") <-- callStatic (sing :: Sing "java.lang.ClassLoader") "getSystemClassLoader" []- forM_ keys $ \key -> do- sptr :: StaticPtr Any <- fromJust <$> unsafeLookupStaticPtr key- let !x = deRefStaticPtr sptr- HeapView.getClosureData x >>= \case- HeapView.ConsClosure{..}- | "inline-java" `isPrefixOf` pkg- , intercalate "." [modl, name] == show 'DotClass -> do- clsPtr <- fromJust <$> unsafeLookupStaticPtr key- let DotClass clsname bcode = deRefStaticPtr clsPtr- _ <- defineClass clsname loader bcode- return ()- _ -> return ()+ 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)) =- "Inline__" ++ filter isAlphaNum pkgname ++ "_" ++ map (\case '.' -> '_'; x -> x) mname+ mangleClassName pkgname mname blockOrExpQQ :: String -> Q TH.Exp blockOrExpQQ txt@(words -> toks) -- ignore whitespace@@ -333,72 +181,26 @@ expQQ input = blockQQ $ "{ return " ++ input ++ "; }" blockQQ :: String -> Q TH.Exp-blockQQ input = case Java.parser Java.block input of- Left err -> fail $ show err- Right block -> do- mname <- TH.newName "function"- pushWrapperGen $ do- vtys <- forM (antis block) $ \v -> do- name <- getValueName v- info <- TH.reify name- case info of-#if MIN_VERSION_template_haskell(2,11,0)- TH.VarI _ ty _ -> do-#else- TH.VarI _ ty _ _ -> do-#endif- -- First (recursively) unfold type synonyms, if any.- ty' <- unfoldHeadTySyn ty- case ty' of- TH.AppT (TH.ConT nJ) thty- | nJ == ''J -> do- unliftJType thty >>= \case- SomeSing ty1 -> return $ (Java.Ident ('$':v), toJavaType ty1)- _ -> do- targetty <- TH.newName "a"- instances <- TH.reifyInstances ''Coercible [ty, TH.VarT targetty]- jty <- case instances of- [TH.InstanceD _ _ (TH.AppT (TH.AppT _ _) thty) _] ->- unliftJType thty >>= \case- SomeSing ty1 -> return $ toJavaType ty1- [] -> fail $ "No Coercible instance for type " ++ show (TH.ppr ty)- _ ->- fail $- "Ambiguous argument type " ++- show (TH.ppr ty) ++- ". Several Coercible instances apply."- return (Java.Ident ('$':v), jty)- _ -> fail $ v ++ " not a valid variable name."- let retty = toJavaType (SClass "java.lang.Object")- return $ abstract- (Java.Ident (show mname))- (Just retty)- vtys- block+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 =<< getValueName v) |] | v <- antis block ]+ let args = [ [| coerce $(TH.varE name) |] | name <- thnames ] thismod <- TH.thisModule- castReturnType- [| loadJavaWrappers >>- callStatic- (sing :: Sing $(TH.litT $ TH.strTyLit ("io.tweag.inlinejava." ++ mangle thismod)))- (fromString $(TH.stringE (show mname)))- $(TH.listE args) :: IO (J ('Class "java.lang.Object")) |]- where- -- As of GHC 8.0.2, 'addModFinalizer' will only see variables that are- -- already in scope at the call site, not new variables that are spliced- -- in. So we can't get at the return type of the call to the wrapper we- -- just generated. Therefore, we have no choice but to assume all wrappers- -- always return java.lang.Object. This works, because in Java >= 5 if- -- what you have is a primitive type but what you're requesting is an- -- object type, then the value of primitive type gets autoboxed. So now we- -- have to guess on the Haskell side what autoboxing did, to reverse its- -- effect. Alternatively, we can say that for now we only support- -- returning boxed values. Once this limitation of the compiler gets- -- lifted, we'll support returning unboxed values, just like `call` does.- castReturnType funcall = [| unsafeUncoerce . coerce <$> $funcall |]- unfoldHeadTySyn ty@(TH.ConT nT) = do- TH.reify nT >>= \case- TH.TyConI (TH.TySynD _ _ ty') -> unfoldHeadTySyn ty'- _ -> return ty- unfoldHeadTySyn ty = return ty+ 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/Magic.hsc view
@@ -0,0 +1,115 @@+-- | Internal module defining some magic, kept separate from the rest, that+-- depends on compiler internals.++{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -ddump-ds #-}++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)++#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+ (Coercibles args_tuple args_tys, Coercible b tyres, 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 (Coercible x ty, Coercibles xs tys) => Coercibles (x, xs) '(ty, tys)
+ src/Language/Java/Inline/Plugin.hs view
@@ -0,0 +1,478 @@+-- | 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 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+import TyCoRep+import TysWiredIn (nilDataConName, consDataConName)+import System.Directory (listDirectory)+import System.FilePath ((</>), (<.>))+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+ reinitializeGlobals+ 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 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+ let f = "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 :: [QQOcc] -> [JavaImport] -> CoreM Builder+buildJava qqOccs jimports = do+ let importsJava = mconcat+ [ mconcat [ "import ", Builder.stringUtf8 jimp+ , "; // .hs:", Builder.integerDec n+ , "\n"+ ]+ | JavaImport jimp n <- jimports+ ]+ methods <- forM qqOccs $ \QQOcc {..} -> do+ jTypeNames <- findJTypeNames+ resty <- case toJavaType jTypeNames (expandTypeSynonyms qqOccResTy) 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 (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
tests/Language/Java/InlineSpec.hs view
@@ -1,44 +1,78 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}--- Test that inline-java produces code without warnings.-{-# OPTIONS_GHC -Wall -Werror #-}+{-# 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.Types (JObject)+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 |] >>= reify) `shouldReturn` (2 :: Int32)+ [java| 1 + 1 |] `shouldReturn` (2 :: Int32) it "Evaluates simple blocks" $ do- ([java| {+ [java| { int x = 1; int y = 2; return x + y;- } |] >>= reify) `shouldReturn` (3 :: Int32)+ } |] `shouldReturn` (3 :: Int32) it "Supports antiquotation variables" $ do let x = 1 :: Int32- ([java| $x + 1 |] >>= reify) `shouldReturn` (2 :: Int32)+ [java| $x + 1 |] `shouldReturn` (2 :: Int32) - it "Supports type synonym'ed antiquotation variables" $ do- obj <- [java| new Object() {} |]- let obj1 = obj :: JObject- _ :: JObject <- [java| $obj1 |]- return ()+ 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 |] >>= reify) `shouldReturn` (3 :: Int32)+ [java| $foo + $bar |] `shouldReturn` (3 :: Int32) it "Supports repeated antiquotation variables" $ do obj :: JObject <- [java| new Object() {} |]@@ -46,11 +80,47 @@ it "Supports antiquotation variables in blocks" $ do let z = 1 :: Int32- ([java| { return $z + 1; } |] >>= reify) `shouldReturn` (2 :: 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() {}) |] >>= reify) `shouldReturn` False+ [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