{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Language.Java.Inline.Internal
( javaWithConfig
, QQConfig(..)
, imports
, loadJavaWrappers
) where
import Control.Monad (when)
import Data.Data
import Data.List (isPrefixOf, intercalate, isSuffixOf, nub)
import Data.String (fromString)
import Foreign.JNI (defineClass)
import Language.Java
import Language.Java.Inline.Internal.Magic as Magic
import qualified Language.Java.Lexer as Java
import Language.Haskell.TH.Quote
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH (Q)
import System.IO.Unsafe (unsafePerformIO)
javaWithConfig :: QQConfig -> QuasiQuoter
javaWithConfig :: QQConfig -> QuasiQuoter
javaWithConfig QQConfig
config = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = \String
txt -> QQConfig -> String -> Q Exp
blockOrExpQQ QQConfig
config String
txt
, quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"Language.Java.Inline: quotePat"
, quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"Language.Java.Inline: quoteType"
, quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Language.Java.Inline: quoteDec"
}
newtype IJState = IJState { IJState -> Integer
methodCount :: Integer }
initialIJState :: IJState
initialIJState :: IJState
initialIJState = Integer -> IJState
IJState Integer
0
getIJState :: Q IJState
getIJState :: Q IJState
getIJState = Q (Maybe IJState)
forall a. Typeable a => Q (Maybe a)
TH.getQ Q (Maybe IJState) -> (Maybe IJState -> Q IJState) -> Q IJState
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe IJState
Nothing -> do
IJState -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ IJState
initialIJState
IJState -> Q IJState
forall (m :: * -> *) a. Monad m => a -> m a
return IJState
initialIJState
Just IJState
st -> IJState -> Q IJState
forall (m :: * -> *) a. Monad m => a -> m a
return IJState
st
setIJState :: IJState -> Q ()
setIJState :: IJState -> Q ()
setIJState = IJState -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ
imports :: String -> Q [TH.Dec]
imports :: String -> Q [Dec]
imports String
imp = do
Type
tJI <- [t| Magic.JavaImport |]
Integer
lineNumber <- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> (Loc -> Int) -> Loc -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Loc -> (Int, Int)) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> (Int, Int)
TH.loc_start (Loc -> Integer) -> Q Loc -> Q Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
TH.location
Exp
expJI <- JavaImport -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift (String -> Integer -> JavaImport
Magic.JavaImport String
imp Integer
lineNumber)
[Dec] -> Q ()
TH.addTopDecls
[ Pragma -> Dec
TH.PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ AnnTarget -> Exp -> Pragma
TH.AnnP AnnTarget
TH.ModuleAnnotation (Exp -> Type -> Exp
TH.SigE Exp
expJI Type
tJI) ]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
nextMethodIdx :: Q Integer
nextMethodIdx :: Q Integer
nextMethodIdx = do
IJState
ij <- Q IJState
getIJState
IJState -> Q ()
setIJState (IJState -> Q ()) -> IJState -> Q ()
forall a b. (a -> b) -> a -> b
$ IJState
ij { methodCount :: Integer
methodCount = IJState -> Integer
methodCount IJState
ij Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 }
Integer -> Q Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Q Integer) -> Integer -> Q Integer
forall a b. (a -> b) -> a -> b
$ IJState -> Integer
methodCount IJState
ij
loadJavaWrappers :: IO ()
loadJavaWrappers :: IO ()
loadJavaWrappers = ()
doit () -> IO () -> IO ()
`seq` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
{-# NOINLINE doit #-}
doit :: ()
doit = IO () -> ()
forall a. IO a -> a
unsafePerformIO (IO () -> ()) -> IO () -> ()
forall a b. (a -> b) -> a -> b
$ IO (Pop ()) -> IO ()
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
m (Pop a) -> m a
push (IO (Pop ()) -> IO ()) -> IO (Pop ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
J ('Class "java.lang.ClassLoader")
loader :: J ('Class "java.lang.ClassLoader") <- do
J ('Class "java.lang.Thread")
thr <- String -> String -> IO (J ('Class "java.lang.Thread"))
forall a (ty :: JType) f.
(ty ~ Ty a, Coercible a, VariadicIO f a) =>
String -> String -> f
callStatic String
"java.lang.Thread" String
"currentThread"
J ('Class "java.lang.Thread")
-> String -> IO (J ('Class "java.lang.ClassLoader"))
forall a b (ty :: JType) f.
(VariadicIO f b, ty ~ Ty a, IsReferenceType ty, Coercible a,
Coercible b, Coercible a (J ty)) =>
a -> String -> f
call (J ('Class "java.lang.Thread")
thr :: J ('Class "java.lang.Thread")) String
"getContextClassLoader"
(DotClass -> IO ()) -> IO ()
Magic.forEachDotClass ((DotClass -> IO ()) -> IO ()) -> (DotClass -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Magic.DotClass{String
ByteString
classBytecode :: DotClass -> ByteString
className :: DotClass -> String
classBytecode :: ByteString
className :: String
..} -> do
JClass
_ <- ReferenceTypeName
-> J ('Class "java.lang.ClassLoader") -> ByteString -> IO JClass
forall o.
Coercible o (J ('Class "java.lang.ClassLoader")) =>
ReferenceTypeName -> o -> ByteString -> IO JClass
defineClass (Sing ('Class Any) -> ReferenceTypeName
forall (ty :: JType).
IsReferenceType ty =>
Sing ty -> ReferenceTypeName
referenceTypeName (String -> SJType ('Class Any)
forall (sym :: Symbol). String -> SJType ('Class sym)
SClass String
className)) J ('Class "java.lang.ClassLoader")
loader ByteString
classBytecode
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IO (Pop ())
forall (m :: * -> *). Monad m => m (Pop ())
pop
mangle :: TH.Module -> String
mangle :: Module -> String
mangle (TH.Module (TH.PkgName String
pkgname) (TH.ModName String
mname)) =
String -> String -> String
Magic.mangleClassName String
pkgname String
mname
data QQConfig = QQConfig
{
QQConfig -> Name
qqMarker :: TH.Name
, QQConfig -> [Q Exp] -> Q Exp
qqCallStatic :: [TH.ExpQ] -> TH.ExpQ
, QQConfig -> Q Exp -> Q Exp
qqWrapMarker :: TH.ExpQ -> TH.ExpQ
}
blockOrExpQQ :: QQConfig -> String -> Q TH.Exp
blockOrExpQQ :: QQConfig -> String -> Q Exp
blockOrExpQQ QQConfig
config txt :: String
txt@(String -> [String]
words -> [String]
toks)
| [String
"{"] [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [String]
toks
, [String
"}"] [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [String]
toks = QQConfig -> String -> Q Exp
blockQQ QQConfig
config String
txt
| Bool
otherwise = QQConfig -> String -> Q Exp
expQQ QQConfig
config String
txt
expQQ :: QQConfig ->String -> Q TH.Exp
expQQ :: QQConfig -> String -> Q Exp
expQQ QQConfig
config String
input = QQConfig -> String -> Q Exp
blockQQ QQConfig
config (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"{ return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
input String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"; }"
blockQQ :: QQConfig -> String -> Q TH.Exp
blockQQ :: QQConfig -> String -> Q Exp
blockQQ QQConfig
config String
input = do
Integer
idx <- Q Integer
nextMethodIdx
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
idx Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
String -> Q ()
TH.addCorePlugin String
"Language.Java.Inline.Plugin"
let mname :: String
mname = String
"inline__method_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
idx
vnames :: [String]
vnames = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub
[ String
n | Java.L (Int, Int)
_ (Java.IdentTok (Char
'$' : String
n)) <- String -> [L Token]
Java.lexer String
input ]
thnames :: [Name]
thnames = (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map String -> Name
TH.mkName [String]
vnames
thnames' :: [Name]
thnames' = (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map String -> Name
TH.mkName ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:) [String]
vnames)
Module
thismod <- Q Module
TH.thisModule
Integer
lineNumber <- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> (Loc -> Int) -> Loc -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Loc -> (Int, Int)) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> (Int, Int)
TH.loc_start (Loc -> Integer) -> Q Loc -> Q Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
TH.location
QQConfig -> Q Exp -> Q Exp
qqWrapMarker QQConfig
config
[| $(TH.varE (qqMarker config))
(Proxy :: Proxy $(TH.litT $ TH.strTyLit input))
(Proxy :: Proxy $(TH.litT $ TH.strTyLit mname))
(Proxy :: Proxy $(TH.litT $ TH.strTyLit $ intercalate "," vnames))
(Proxy :: Proxy $(TH.litT $ TH.numTyLit $ lineNumber))
$(return $ foldr (\a b -> TH.TupE [Just $ TH.VarE a, Just b]) (TH.TupE []) thnames)
Proxy
(\ $(return $ foldr (\a b -> TH.TupP [TH.VarP a, b]) (TH.TupP []) thnames') ->
$(qqCallStatic config $
[ [| fromString $(TH.stringE ("io.tweag.inlinejava." ++ mangle thismod)) |]
, [| fromString $(TH.stringE mname) |]
] ++ map TH.varE thnames'
)
)
|]