-- | = Inline Java quasiquotation
--
-- See the
-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell-quasi-quotation GHC manual>
-- for an introduction to quasiquotation. The quasiquoter exported in this
-- module allows embedding arbitrary Java expressions and blocks of statements
-- inside Haskell code. You can call any Java method and define arbitrary inline
-- code using Java syntax. No FFI required.
--
-- Here is the same example as in "Language.Java", but with inline Java calls:
--
-- @
-- {&#45;\# LANGUAGE DataKinds \#&#45;}
-- {&#45;\# LANGUAGE QuasiQuotes \#&#45;}
-- module Object where
--
-- import Language.Java as J
-- import Language.Java.Inline
--
-- newtype Object = Object ('J' (''Class' "java.lang.Object"))
-- instance 'Coercible' Object
--
-- clone :: Object -> IO Object
-- clone obj = [java| $obj.clone() |]
--
-- equals :: Object -> Object -> IO Bool
-- equals obj1 obj2 = [java| $obj1.equals($obj2) |]
--
-- ...
-- @

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module Language.Java.Inline.Internal
  ( javaWithConfig
  , QQConfig(..)
  , imports
  , loadJavaWrappers
  ) where

import Control.Monad (when)
import Data.Data
import Data.List (isPrefixOf, intercalate, isSuffixOf, nub)
import Data.String (fromString)
import Foreign.JNI (defineClass)
import Language.Java
import Language.Java.Inline.Internal.Magic as Magic
import qualified Language.Java.Lexer as Java
import Language.Haskell.TH.Quote
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH (Q)
import System.IO.Unsafe (unsafePerformIO)

-- Implementation strategy
--
-- We know we'll need to declare a new wrapper (a Java static method), but we
-- don't know the types of the arguments nor the return type. So we first name
-- this method and generate a Haskell call to it at the quasiquotation site.
-- Then, we inject a call to 'qqMarker' which carries the needed types to the
-- plugin phase.
--
-- The plugin phase is implemented in Language.Java.Inline.Plugin. In this phase
-- we make a pass over the module Core to find all the occurrences of
-- 'qqMarker'. By this point the types of all the variables in the local scope
-- that was captured are fully determined. So we can analyze these types to
-- determine what the signature of the wrapper should be, in order to declare
-- it.
--
-- The last step is to ask the Java toolchain to produce .class bytecode from
-- our declarations. We embed this bytecode in the binary, adding a reference to
-- it in a global bytecode table. That way at runtime we can enumerate
-- the bytecode blobs, and load them into the JVM one by one.

javaWithConfig :: QQConfig -> QuasiQuoter
javaWithConfig :: 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"
    }

-- | Private newtype to key the TH state.
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

-- | Declares /import/ statements to be included in the java compilation unit.
-- e.g.
--
-- > imports "java.util.*"
--
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
      -- {-# ANN module (JavaImport imp :: JavaImport) #-}
      [ 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 []

-- | Yields the next method index. A different index is produced per call.
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

-- | Idempotent action that loads all wrappers in every module of the current
-- program into the JVM. You shouldn't need to call this yourself.
loadJavaWrappers :: IO ()
loadJavaWrappers :: 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

-- | Customizes how quasiquotations are desugared.
data QQConfig = QQConfig
  { -- | This is the name of the function to use to indicate to the
    -- plugin the presence of a java quasiquotation.
    QQConfig -> Name
qqMarker :: TH.Name
    -- | This produces the call invoke the Java stub.
    -- It takes the list of arguments that should be passed to the call.
  , QQConfig -> [Q Exp] -> Q Exp
qqCallStatic :: [TH.ExpQ] -> TH.ExpQ
    -- | This is given as argument the invocation of the Java stub, and
    -- is expected to prepend it with code that ensures that the stub is
    -- previously loaded in the JVM.
  , 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) -- ignore whitespace
  | [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)

      -- Return a call to the static method we just generated.
      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'
                 )
             )
             |]