diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,12 @@ # inline-java: Call any JVM function from Haskell -[![wercker status](https://app.wercker.com/status/dfeba78838cc77d4c5e06eedc5c0833d/s/master "wercker status")](https://app.wercker.com/project/byKey/dfeba78838cc77d4c5e06eedc5c0833d) +[![CircleCI](https://circleci.com/gh/tweag/inline-java.svg?style=svg)](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 `.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 -![Tweag I/O](http://i.imgur.com/0HK8X4y.png) +         +[![Tweag I/O](http://i.imgur.com/0HK8X4y.png)](http://tweag.io) +             +[![LeapYear](http://i.imgur.com/t9VxRHn.png)](http://leapyear.io) inline-java is maintained by [Tweag I/O](http://tweag.io/). diff --git a/cbits/bctable.c b/cbits/bctable.c new file mode 100644 --- /dev/null +++ b/cbits/bctable.c @@ -0,0 +1,17 @@ +#include "bctable.h" +#include + +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; diff --git a/cbits/bctable.h b/cbits/bctable.h new file mode 100644 --- /dev/null +++ b/cbits/bctable.h @@ -0,0 +1,32 @@ +#include + +/** 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; diff --git a/inline-java.cabal b/inline-java.cabal --- a/inline-java.cabal +++ b/inline-java.cabal @@ -1,5 +1,5 @@ name: inline-java -version: 0.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 diff --git a/src/Language/Java/Inline.hs b/src/Language/Java/Inline.hs --- a/src/Language/Java/Inline.hs +++ b/src/Language/Java/Inline.hs @@ -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 --- , 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)) |] diff --git a/src/Language/Java/Inline/Magic.hsc b/src/Language/Java/Inline/Magic.hsc new file mode 100644 --- /dev/null +++ b/src/Language/Java/Inline/Magic.hsc @@ -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) diff --git a/src/Language/Java/Inline/Plugin.hs b/src/Language/Java/Inline/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Language/Java/Inline/Plugin.hs @@ -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___ { +-- > 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___" "inline__method_i" [])) +-- > ... +-- > +-- > g = ... +-- > ... +-- +-- 'collectQQMarkers' yields one 'QQOcc' value for every occurrences of +-- 'qqMarker', and the program resulting from removing the markers. +-- +-- > module A where +-- > import Language.Java.Inline +-- > +-- > f = ... +-- > (callStatic "Inline___" "inline__method_i" []) +-- > ... +-- > +-- > g = ... +-- > ... +-- +collectQQMarkers + :: Name -> CoreProgram -> CoreM (CoreProgram, [QQOcc]) +collectQQMarkers qqMarkerName p0 = do + (p1, e) <- runWriterT (mapM bindMarkers p0) + return (p1, appEndo e []) + where + bindMarkers :: CoreBind -> QQJavaM CoreBind + bindMarkers (NonRec b e) = NonRec b <$> expMarkers e + bindMarkers (Rec bs) = Rec <$> mapM (\(b, e) -> (,) b <$> expMarkers e) bs + + expMarkers :: CoreExpr -> QQJavaM CoreExpr + expMarkers (App (App (App (App (App (App (App (App (App (App (App (App (App + (App (App (App (App (App (App (Var fid) _) + (Type (parseArgTys -> Just tyargs))) + (Type tyres)) + (Type (LitTy (StrTyLit fs_input)))) + (Type (LitTy (StrTyLit fs_mname)))) + (Type (LitTy (StrTyLit fs_antiqs)))) + (Type (LitTy (NumTyLit lineNumber)))) + _) _) _) _) _) _) _) _) _) _) _) + e + ) + | qqMarkerName == idName fid = do + tell $ Endo $ (:) $ QQOcc + { qqOccResTy = tyres + , qqOccArgTys = tyargs + , qqOccInput = fastStringToByteString fs_input + , qqOccMName = fastStringToByteString fs_mname + , qqOccAntiQs = fastStringToByteString fs_antiqs + , qqOccLineNumber = lineNumber + } + return e + expMarkers (Var fid) | qqMarkerName == idName fid = lift $ failWith $ + text "inline-java Plugin: found invalid qqMarker." + expMarkers (App e a) = App <$> expMarkers e <*> expMarkers a + expMarkers (Lam b e) = Lam b <$> expMarkers e + expMarkers (Let bnd e) = Let <$> bindMarkers bnd <*> expMarkers e + expMarkers (Case e0 b t alts) = do + e0' <- expMarkers e0 + let expAlt (a, bs, e) = (,,) a bs <$> expMarkers e + alts' <- mapM expAlt alts + return (Case e0' b t alts') + expMarkers (Cast e c) = flip Cast c <$> expMarkers e + expMarkers (Tick t e) = Tick t <$> expMarkers e + expMarkers e@(Coercion {}) = return e + expMarkers e@(Lit {}) = return e + expMarkers e@(Var {}) = return e + expMarkers e@(Type {}) = return e + + -- @parseArgTys (t_1, (t_2, ... (t_n, ()) ... )) = Just [t_1, t_2, ... t_n]@ + -- + -- Yields @Nothing@ when the input is not of the expected form. + parseArgTys :: Type -> Maybe [Type] + parseArgTys (TyConApp c [_, _, ty, tys]) + | c == promotedTupleDataCon Boxed 2 = + (ty:) <$> parseArgTys tys + parseArgTys (TyConApp c []) + | c == unitTyCon = + Just [] + parseArgTys _ = Nothing + +-- | Produces static structures which contain the class names and +-- the bytecodes. For instance: +-- +-- > static unsigned char bc0[] = {202, 254, ... } +-- > +-- > static unsigned char bc1[] = {202, 254, ... } +-- > +-- > static struct inline_java_dot_class dcs[] = +-- > { { "io.tweag.inlinejava.Inline__main_Language_Java_InlineSpec" +-- > , 2941 // length of bc0 +-- > , bc0 +-- > } +-- > , { "io.tweag.inlinejava.Inline__main_Language_Java_InlineSpec$1Foo" +-- > , 579 // length of bc1 +-- > , bc1 +-- > } +-- > }; +-- > +dotClasses :: [DotClass] -> SDoc +dotClasses dcs = vcat $ + text "static int dc_count =" <+> int (length dcs) <> semi + : [ vcat + [ text "static unsigned char bc" <> int i <> text "[] =" + , braces (pprWithCommas (text . show) (BS.unpack bc)) <> semi + ] + | (i, DotClass _ bc) <- zip [0..] dcs + ] + ++ + [ text "static struct inline_java_dot_class dcs[] =" + , braces + (pprWithCommas + (\(i, DotClass name bc) -> + braces $ pprWithCommas id + [ text (show name), int (BS.length bc), text "bc" <> int i]) + (zip [0..] dcs) + ) <> semi + ] + +-- | Produces the constructor function which inserts the static structures +-- generated by 'dotClasses' into the bytecode table. +cConstructors :: SDoc +cConstructors = vcat + [ text "static void hs_inline_java_init(void) __attribute__((constructor));" + , text "static void hs_inline_java_init(void)" + , text "{ inline_java_bctable = inline_java_new_pack(inline_java_bctable, dcs, dc_count); }" + ] + +-------------------------------------------- +-- Candidates for addition to GhcPlugins +-------------------------------------------- + +-- | Produces a name in GHC Core from a Template Haskell name. +-- +-- Yields Nothing if the name can't be found, which may happen if the +-- module defining the named thing hasn't been loaded. +findTHName :: TH.Name -> CoreM (Maybe Name) +findTHName th_name = + case thRdrNameGuesses th_name of + Orig m occ : _ -> do + hsc_env <- getHscEnv + nc <- liftIO $ readIORef (hsc_NC hsc_env) + return $ lookupOrigNameCache (nsNames nc) m occ + _ -> return Nothing + +-- | Yields module annotations with values of the given type. +getModuleAnnotations :: Data a => ModGuts -> [a] +getModuleAnnotations guts = + mapMaybe (fromSerialized deserializeWithData) + [ v | Annotation (ModuleTarget _) v <- mg_anns guts ] + +-- | Prints the given error message and terminates ghc. +failWith :: SDoc -> CoreM a +failWith m = do + errorMsg m + dflags <- getDynFlags + liftIO $ ghcExit dflags 1 + return (error "ghcExit returned!?") -- unreachable diff --git a/tests/Language/Java/InlineSpec.hs b/tests/Language/Java/InlineSpec.hs --- a/tests/Language/Java/InlineSpec.hs +++ b/tests/Language/Java/InlineSpec.hs @@ -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 xs = Arrays.asList(1, 2); + Collections.sort(xs, (a, b) -> b.compareTo(a)); + return xs.get(0); + } |] `shouldReturn` (2 :: Int32) + + it "Can be used inside brackets" $ do + $([| let _x = 1 :: Int32 -- Named _x to avoid spurious "unused" warning + in (+1) <$> [java| $_x |] + |]) `shouldReturn` (2 :: Int32) + + it "Can throw checked exceptions" $ do + ([java| { throw new InterruptedException(); } |] :: IO ()) + `shouldThrow` \(_ :: JVMException) -> True + + it "Type-checks generics" $ do + obj :: List ('Class "java.lang.String") <- + [java| new ArrayList() |] + _ :: List ('Class "java.lang.String") <- [java| $obj |] + return () + + it "Can access inner classes" $ do + st :: J ('Class "java.lang.Thread$State") <- + [java| Thread.State.NEW |] + [java| $st == Thread.State.NEW |] `shouldReturn` True