-- | This plugin generates Java bytecode from modules using the java
-- QuasiQuoter and inserts it in a global bytecode table from where
-- it is loaded at runtime.
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Language.Java.Inline.Plugin (plugin) where

import Control.Applicative ((<|>))
import Control.Monad.Writer hiding ((<>))
import qualified Data.ByteString as BS
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as Builder
import Data.Char (chr, ord)
import Data.List (find, intersperse, isSuffixOf)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified FastString.Extras
import Foreign.JNI.Types (JType(..))
import GhcPlugins.Extras
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import Language.Java.Inline.Internal.Magic
import Language.Java.Inline.Internal.QQMarker.Names (getQQMarkers)
import System.Directory (listDirectory)
import System.FilePath ((</>), (<.>), takeDirectory)
import System.IO (withFile, IOMode(WriteMode), hPutStrLn, stderr)
import System.IO.Temp (withSystemTempDirectory)
import System.Process (callProcess)
import Prelude hiding ((<>))

-- The 'java' quasiquoter produces annotations of type 'JavaImport', and it also
-- inserts calls in the code to the function 'qqMarker'.
--
-- 'qqMarker' carries many bits of information that are useful in generating the
-- QQ code.
--
-- This plugin first makes a pass to collect the 'qqMarker' calls in the module
-- (collectQQMarkers).
--
-- Then it translates the Core Types to Java types (unliftJTypes).
--
-- Then it generates the java stubs from the information extracted from the
-- occurrences of 'qqMarker' (buildJava).
--
-- Finally, it calls the java compiler to produce the bytecode and
-- arranges to have it inserted in the bytecode table in constructor functions
-- (cConstructors).

plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin
    { installCoreToDos :: CorePlugin
installCoreToDos = CorePlugin
install
    , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile = [CommandLineOption] -> IO PluginRecompile
flagRecompile
    }
  where
    install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
    install :: CorePlugin
install [CommandLineOption]
args [CoreToDo]
todo = do
      let passName :: CommandLineOption
passName = CommandLineOption
"inline-java"
      if CommandLineOption -> [CoreToDo] -> Bool
inTodo CommandLineOption
passName [CoreToDo]
todo then [CoreToDo] -> CoreM [CoreToDo]
forall (m :: * -> *) a. Monad m => a -> m a
return [CoreToDo]
todo
      else [CoreToDo] -> CoreM [CoreToDo]
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandLineOption -> CorePluginPass -> CoreToDo
CoreDoPluginPass CommandLineOption
passName ([CommandLineOption] -> CorePluginPass
qqPass [CommandLineOption]
args) CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: [CoreToDo]
todo)

    inTodo :: String -> [CoreToDo] -> Bool
    inTodo :: CommandLineOption -> [CoreToDo] -> Bool
inTodo CommandLineOption
name = \case
      CoreDoPluginPass CommandLineOption
n CorePluginPass
_ : [CoreToDo]
xs -> CommandLineOption
n CommandLineOption -> CommandLineOption -> Bool
forall a. Eq a => a -> a -> Bool
== CommandLineOption
name Bool -> Bool -> Bool
|| CommandLineOption -> [CoreToDo] -> Bool
inTodo CommandLineOption
name [CoreToDo]
xs
      CoreToDo
_ : [CoreToDo]
xs -> CommandLineOption -> [CoreToDo] -> Bool
inTodo CommandLineOption
name [CoreToDo]
xs
      [] -> Bool
False

    qqPass :: [CommandLineOption] -> ModGuts -> CoreM ModGuts
    qqPass :: [CommandLineOption] -> CorePluginPass
qqPass [CommandLineOption]
args ModGuts
guts = do
      CoreM [Name]
getQQMarkers CoreM [Name] -> ([Name] -> CoreM ModGuts) -> CoreM ModGuts
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- If qqMarkers cannot be found we assume the module does not use
        -- inline-java.
        [] -> CorePluginPass
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
        [Name]
qqMarkerNames -> do
          (CoreProgram
binds, [QQOcc]
qqOccs) <- [Name] -> CoreProgram -> CoreM (CoreProgram, [QQOcc])
collectQQMarkers [Name]
qqMarkerNames (ModGuts -> CoreProgram
mg_binds ModGuts
guts)
          let jimports :: [JavaImport]
jimports =
                ModGuts -> [JavaImport]
forall a. Data a => ModGuts -> [a]
GhcPlugins.Extras.getModuleAnnotations ModGuts
guts :: [JavaImport]
          [DotClass]
dcs <- ModGuts -> [QQOcc] -> [JavaImport] -> CoreM Builder
buildJava ModGuts
guts [QQOcc]
qqOccs [JavaImport]
jimports
                   CoreM Builder -> (Builder -> CoreM Builder) -> CoreM Builder
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [CommandLineOption] -> Builder -> CoreM Builder
maybeDumpJava [CommandLineOption]
args
                   CoreM Builder -> (Builder -> CoreM [DotClass]) -> CoreM [DotClass]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [CommandLineOption] -> Builder -> CoreM [DotClass]
buildBytecode [CommandLineOption]
args
          CorePluginPass
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
            { mg_binds :: CoreProgram
mg_binds = CoreProgram
binds
            , mg_foreign :: ForeignStubs
mg_foreign = ForeignStubs -> SDoc -> ForeignStubs
appendStubC (ModGuts -> ForeignStubs
mg_foreign ModGuts
guts) (SDoc -> ForeignStubs) -> SDoc -> ForeignStubs
forall a b. (a -> b) -> a -> b
$
                             CommandLineOption -> SDoc
text CommandLineOption
bctable_header
                           SDoc -> SDoc -> SDoc
$$ [DotClass] -> SDoc
dotClasses [DotClass]
dcs
                           SDoc -> SDoc -> SDoc
$$ SDoc
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 :: CommandLineOption
bctable_header = $(do
        loc <- TH.location
        let root = iterate takeDirectory (TH.loc_filename loc) !! 6
            f = root </> "cbits/bctable.h"
        TH.addDependentFile f
        TH.lift =<< TH.runIO (readFile f)
      )
    -- Dumps the java code to stderr or a file, depending on the set flags.
    maybeDumpJava :: [CommandLineOption] -> Builder -> CoreM Builder
    maybeDumpJava :: [CommandLineOption] -> Builder -> CoreM Builder
maybeDumpJava [CommandLineOption]
args Builder
b
      | CommandLineOption -> [CommandLineOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem CommandLineOption
"dump-java" [CommandLineOption]
args = do
        DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DumpToFile DynFlags
dflags then do
          Module
thisModule <- CoreM Module
forall (m :: * -> *). HasModule m => m Module
getModule
          let fname :: CommandLineOption
fname = ModuleName -> CommandLineOption
moduleNameString (Module -> ModuleName
moduleName Module
thisModule) CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
".dump-java"
              path :: CommandLineOption
path = CommandLineOption
-> (CommandLineOption -> CommandLineOption)
-> Maybe CommandLineOption
-> CommandLineOption
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CommandLineOption
fname (CommandLineOption -> CommandLineOption -> CommandLineOption
</> CommandLineOption
fname) (DynFlags -> Maybe CommandLineOption
dumpDir DynFlags
dflags)
          IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. CommandLineOption -> IOMode -> (Handle -> IO r) -> IO r
withFile CommandLineOption
path IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Builder -> IO ()
Builder.hPutBuilder Handle
h Builder
b
        else IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ do
          Handle -> CommandLineOption -> IO ()
hPutStrLn Handle
stderr CommandLineOption
"=== inline-java (dump-java) BEGIN ==="
          Handle -> Builder -> IO ()
Builder.hPutBuilder Handle
stderr Builder
b
          Handle -> CommandLineOption -> IO ()
hPutStrLn Handle
stderr CommandLineOption
"=== inline-java (dump-java) END ==="
        Builder -> CoreM Builder
forall (m :: * -> *) a. Monad m => a -> m a
return Builder
b
    maybeDumpJava [CommandLineOption]
_ Builder
b = Builder -> CoreM Builder
forall (m :: * -> *) a. Monad m => a -> m a
return Builder
b

-- | Produces a Java compilation unit from the quasiquotation occurrences and
-- the java imports.
--
-- The compilation unit looks like:
--
-- > package io.tweag.inlinejava;
-- > import java.util.*; // .hs:25
-- >
-- > public final class Inline__<pkgname>_<modname> {
-- > public static java.lang.Object method_0()
-- > { return  1 + 1 ; } // .hs:31
-- > public static java.lang.Object inline__method_1()
-- > { // .hs:34
-- >              int x = 1; // .hs:34
-- >              int y = 2; // .hs:34
-- >              return x + y; // .hs:34
-- >            } // .hs:34
-- > public static java.lang.Object inline__method_2(final int $x)
-- > { return  $x + 1 ; } // .hs:42
-- > public static java.lang.Object inline__method_3()
-- > { return  new Object() {} ; } // .hs:46
-- > }
--
-- Where @inline_method_i@ is the method corresponding to the @ith@
-- quasiquotation.
buildJava :: ModGuts -> [QQOcc] -> [JavaImport] -> CoreM Builder
buildJava :: ModGuts -> [QQOcc] -> [JavaImport] -> CoreM Builder
buildJava ModGuts
guts [QQOcc]
qqOccs [JavaImport]
jimports = do
    let importsJava :: Builder
importsJava = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
          [ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Builder
"import ", CommandLineOption -> Builder
Builder.stringUtf8 CommandLineOption
jimp
                    , Builder
"; // .hs:", Integer -> Builder
Builder.integerDec Integer
n
                    , Builder
"\n"
                    ]
          | JavaImport CommandLineOption
jimp Integer
n <- [JavaImport]
jimports
          ]
    PackageFamInstEnv
p_fam_env <- CoreM PackageFamInstEnv
getPackageFamInstEnv
    let fam_envs :: (PackageFamInstEnv, PackageFamInstEnv)
fam_envs = (PackageFamInstEnv
p_fam_env, ModGuts -> PackageFamInstEnv
mg_fam_inst_env ModGuts
guts)
    [Builder]
methods <- [QQOcc] -> (QQOcc -> CoreM Builder) -> CoreM [Builder]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [QQOcc]
qqOccs ((QQOcc -> CoreM Builder) -> CoreM [Builder])
-> (QQOcc -> CoreM Builder) -> CoreM [Builder]
forall a b. (a -> b) -> a -> b
$ \QQOcc {Integer
[Type]
ByteString
Type
qqOccLineNumber :: QQOcc -> Integer
qqOccAntiQs :: QQOcc -> ByteString
qqOccMName :: QQOcc -> ByteString
qqOccInput :: QQOcc -> ByteString
qqOccArgTys :: QQOcc -> [Type]
qqOccResTy :: QQOcc -> Type
qqOccLineNumber :: Integer
qqOccAntiQs :: ByteString
qqOccMName :: ByteString
qqOccInput :: ByteString
qqOccArgTys :: [Type]
qqOccResTy :: Type
..} -> do
      let (Coercion
_, Type
normty) = (PackageFamInstEnv, PackageFamInstEnv)
-> Role -> Type -> (Coercion, Type)
normaliseType (PackageFamInstEnv, PackageFamInstEnv)
fam_envs Role
Nominal (Type -> Type
expandTypeSynonyms Type
qqOccResTy)
      JTypeNames
jTypeNames <- CoreM JTypeNames
findJTypeNames
      ByteString
resty <- case JTypeNames -> Type -> Maybe ByteString
toJavaType JTypeNames
jTypeNames Type
normty of
        Just ByteString
resty -> ByteString -> CoreM ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
resty
        Maybe ByteString
Nothing -> SDoc -> CoreM ByteString
forall a. SDoc -> CoreM a
GhcPlugins.Extras.failWith (SDoc -> CoreM ByteString) -> SDoc -> CoreM ByteString
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
          [ SDoc -> SDoc
parens (CommandLineOption -> SDoc
text CommandLineOption
"line" SDoc -> SDoc -> SDoc
<+> Integer -> SDoc
integer Integer
qqOccLineNumber) SDoc -> SDoc -> SDoc
<> SDoc
":"
          , CommandLineOption -> SDoc
text CommandLineOption
"The result type of the quasiquotation"
          , SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
qqOccResTy)
          , CommandLineOption -> SDoc
text CommandLineOption
"is not sufficiently instantiated to infer a java type."
          ]
      let argnames :: [ByteString]
argnames = Word8 -> ByteString -> [ByteString]
BS.split (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
',') ByteString
qqOccAntiQs
      [Builder]
argtys <- (ByteString -> Type -> CoreM Builder)
-> [ByteString] -> [Type] -> CoreM [Builder]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (JTypeNames -> Integer -> ByteString -> Type -> CoreM Builder
getArg JTypeNames
jTypeNames Integer
qqOccLineNumber)
                         [ByteString]
argnames [Type]
qqOccArgTys
      Builder -> CoreM Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> CoreM Builder) -> Builder -> CoreM Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ Builder
"public static "
        , ByteString -> Builder
Builder.byteString ByteString
resty
        , Builder
" "
        , ByteString -> Builder
Builder.byteString ByteString
qqOccMName
        , Builder
"("
        , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
"," [Builder]
argtys
        , Builder
") throws Throwable // .hs:"
        , Integer -> Builder
Builder.integerDec Integer
qqOccLineNumber
        , Builder
"\n"
        , Integer -> ByteString -> Builder
adjustInput Integer
qqOccLineNumber ByteString
qqOccInput
        ]
    Module
thisModule <- CoreM Module
forall (m :: * -> *). HasModule m => m Module
getModule
    let className :: CommandLineOption
className = Module -> CommandLineOption
mangle Module
thisModule
    Builder -> CoreM Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> CoreM Builder) -> Builder -> CoreM Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
      [ Builder
"package io.tweag.inlinejava;\n"
      , Builder
importsJava
      , Builder
"\n"
      , Builder
"public final class "
      , CommandLineOption -> Builder
Builder.stringUtf8 CommandLineOption
className
      , Builder
" {\n"
      , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
methods
      , Builder
"}\n"
      ]
  where
    getArg :: JTypeNames -> Integer -> BS.ByteString -> Type -> CoreM Builder
    getArg :: JTypeNames -> Integer -> ByteString -> Type -> CoreM Builder
getArg JTypeNames
jTypeNames Integer
_ ByteString
name
           (Type -> Type
expandTypeSynonyms -> JTypeNames -> Type -> Maybe ByteString
toJavaType JTypeNames
jTypeNames -> Just ByteString
jtype) =
      Builder -> CoreM Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> CoreM Builder) -> Builder -> CoreM Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [Builder
"final ", ByteString -> Builder
Builder.byteString ByteString
jtype, Builder
" $", ByteString -> Builder
Builder.byteString ByteString
name]
    getArg JTypeNames
_ Integer
line ByteString
name Type
t = SDoc -> CoreM Builder
forall a. SDoc -> CoreM a
GhcPlugins.Extras.failWith (SDoc -> CoreM Builder) -> SDoc -> CoreM Builder
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
        [ SDoc -> SDoc
parens (CommandLineOption -> SDoc
text CommandLineOption
"line" SDoc -> SDoc -> SDoc
<+> Integer -> SDoc
integer Integer
line) SDoc -> SDoc -> SDoc
<> SDoc
":"
        , SDoc -> SDoc
quotes (FastString -> SDoc
ftext (ByteString -> FastString
mkFastStringByteString ByteString
name) SDoc -> SDoc -> SDoc
<+> SDoc
"::" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t)
        , CommandLineOption -> SDoc
text CommandLineOption
"is not sufficiently instantiated to infer a java type."
        ]

    adjustInput :: Integer -> BS.ByteString -> Builder
    adjustInput :: Integer -> ByteString -> Builder
adjustInput Integer
lineNumber ByteString
bs =
      let txt :: Text
txt = Text -> Text
Text.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeUtf8 ByteString
bs
          block :: [Text]
block = if Text -> Text -> Bool
Text.isPrefixOf Text
"{" Text
txt Bool -> Bool -> Bool
&& Text -> Text -> Bool
Text.isSuffixOf Text
"}" Text
txt
            then Text -> [Text]
Text.lines Text
txt
            else Text -> [Text]
Text.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat [Text
"{ return ", Text
txt, Text
"}" ]

       in ByteString -> Builder
Builder.byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines
            [ [Text] -> Text
Text.concat [Text
ln, Text
" // .hs:", CommandLineOption -> Text
Text.pack (Integer -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Integer
lineNumber)]
            | Text
ln <- [Text]
block
            ]

-- | Produces a class name from a Module.
mangle :: Module -> String
mangle :: Module -> CommandLineOption
mangle Module
m = CommandLineOption -> CommandLineOption -> CommandLineOption
mangleClassName (UnitId -> CommandLineOption
unitIdString (UnitId -> CommandLineOption) -> UnitId -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ Module -> UnitId
moduleUnitId Module
m)
                           (ModuleName -> CommandLineOption
moduleNameString (Module -> ModuleName
moduleName Module
m))

-- Call the java compiler and feeds it the given Java code in Builder form.
buildBytecode :: [CommandLineOption] -> Builder -> CoreM [DotClass]
buildBytecode :: [CommandLineOption] -> Builder -> CoreM [DotClass]
buildBytecode [CommandLineOption]
args Builder
unit = do
    let Just CommandLineOption
javac = (CommandLineOption -> Bool)
-> [CommandLineOption] -> Maybe CommandLineOption
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (CommandLineOption
"javac" CommandLineOption -> CommandLineOption -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) [CommandLineOption]
args Maybe CommandLineOption
-> Maybe CommandLineOption -> Maybe CommandLineOption
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CommandLineOption -> Maybe CommandLineOption
forall (m :: * -> *) a. Monad m => a -> m a
return CommandLineOption
"javac"
    Module
m <- CoreM Module
forall (m :: * -> *). HasModule m => m Module
getModule
    IO [DotClass] -> CoreM [DotClass]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [DotClass] -> CoreM [DotClass])
-> IO [DotClass] -> CoreM [DotClass]
forall a b. (a -> b) -> a -> b
$ CommandLineOption
-> (CommandLineOption -> IO [DotClass]) -> IO [DotClass]
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
CommandLineOption -> (CommandLineOption -> m a) -> m a
withSystemTempDirectory CommandLineOption
"inlinejava" ((CommandLineOption -> IO [DotClass]) -> IO [DotClass])
-> (CommandLineOption -> IO [DotClass]) -> IO [DotClass]
forall a b. (a -> b) -> a -> b
$ \CommandLineOption
dir -> do
      let src :: CommandLineOption
src = CommandLineOption
dir CommandLineOption -> CommandLineOption -> CommandLineOption
</> Module -> CommandLineOption
mangle Module
m CommandLineOption -> CommandLineOption -> CommandLineOption
<.> CommandLineOption
"java"
      CommandLineOption -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. CommandLineOption -> IOMode -> (Handle -> IO r) -> IO r
withFile CommandLineOption
src IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Builder -> IO ()
Builder.hPutBuilder Handle
h Builder
unit
      CommandLineOption -> [CommandLineOption] -> IO ()
callProcess CommandLineOption
javac [CommandLineOption
src]
      -- A single compilation unit can produce multiple class files.
      [CommandLineOption]
classFiles <- (CommandLineOption -> Bool)
-> [CommandLineOption] -> [CommandLineOption]
forall a. (a -> Bool) -> [a] -> [a]
filter (CommandLineOption
".class" CommandLineOption -> CommandLineOption -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) ([CommandLineOption] -> [CommandLineOption])
-> IO [CommandLineOption] -> IO [CommandLineOption]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CommandLineOption -> IO [CommandLineOption]
listDirectory CommandLineOption
dir
      [CommandLineOption]
-> (CommandLineOption -> IO DotClass) -> IO [DotClass]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CommandLineOption]
classFiles ((CommandLineOption -> IO DotClass) -> IO [DotClass])
-> (CommandLineOption -> IO DotClass) -> IO [DotClass]
forall a b. (a -> b) -> a -> b
$ \CommandLineOption
classFile -> do
        ByteString
bcode <- CommandLineOption -> IO ByteString
BS.readFile (CommandLineOption
dir CommandLineOption -> CommandLineOption -> CommandLineOption
</> CommandLineOption
classFile)
        -- Strip the .class suffix.
        let klass :: CommandLineOption
klass = CommandLineOption
"io.tweag.inlinejava." CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> CommandLineOption -> CommandLineOption
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') CommandLineOption
classFile
        DotClass -> IO DotClass
forall (m :: * -> *) a. Monad m => a -> m a
return (DotClass -> IO DotClass) -> DotClass -> IO DotClass
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> ByteString -> DotClass
DotClass CommandLineOption
klass ByteString
bcode

-- | The names of 'JType' data constructors
data JTypeNames = JTypeNames
    { JTypeNames -> Maybe Name
nameClass :: Maybe Name
    , JTypeNames -> Maybe Name
nameIface :: Maybe Name
    , JTypeNames -> Maybe Name
nameArray :: Maybe Name
    , JTypeNames -> Maybe Name
nameGeneric :: Maybe Name
    , JTypeNames -> Maybe Name
namePrim :: Maybe Name
    , JTypeNames -> 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 :: CoreM JTypeNames
findJTypeNames = do
    Maybe Name
nameClass <- Name -> CoreM (Maybe Name)
GhcPlugins.Extras.findTHName 'Class
    Maybe Name
nameIface <- Name -> CoreM (Maybe Name)
GhcPlugins.Extras.findTHName 'Iface
    Maybe Name
nameArray <- Name -> CoreM (Maybe Name)
GhcPlugins.Extras.findTHName 'Array
    Maybe Name
nameGeneric <- Name -> CoreM (Maybe Name)
GhcPlugins.Extras.findTHName 'Generic
    Maybe Name
namePrim <- Name -> CoreM (Maybe Name)
GhcPlugins.Extras.findTHName 'Prim
    Maybe Name
nameVoid <- Name -> CoreM (Maybe Name)
GhcPlugins.Extras.findTHName 'Void
    JTypeNames -> CoreM JTypeNames
forall (m :: * -> *) a. Monad m => a -> m a
return (JTypeNames -> CoreM JTypeNames) -> JTypeNames -> CoreM JTypeNames
forall a b. (a -> b) -> a -> b
$ JTypeNames :: Maybe Name
-> Maybe Name
-> Maybe Name
-> Maybe Name
-> Maybe Name
-> Maybe Name
-> JTypeNames
JTypeNames {Maybe Name
nameVoid :: Maybe Name
namePrim :: Maybe Name
nameGeneric :: Maybe Name
nameArray :: Maybe Name
nameIface :: Maybe Name
nameClass :: Maybe Name
nameVoid :: Maybe Name
namePrim :: Maybe Name
nameGeneric :: Maybe Name
nameArray :: Maybe Name
nameIface :: Maybe Name
nameClass :: Maybe Name
..}

-- | 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 -> Type -> Maybe ByteString
toJavaType JTypeNames {Maybe Name
nameVoid :: Maybe Name
namePrim :: Maybe Name
nameGeneric :: Maybe Name
nameArray :: Maybe Name
nameIface :: Maybe Name
nameClass :: Maybe Name
nameVoid :: JTypeNames -> Maybe Name
namePrim :: JTypeNames -> Maybe Name
nameGeneric :: JTypeNames -> Maybe Name
nameArray :: JTypeNames -> Maybe Name
nameIface :: JTypeNames -> Maybe Name
nameClass :: JTypeNames -> Maybe Name
..} Type
t0 = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> Maybe [ByteString] -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe [ByteString]
go Type
t0
  where
    go :: Type -> Maybe [BS.ByteString]
    go :: Type -> Maybe [ByteString]
go (TyConApp TyCon
c [LitTy (StrTyLit FastString
fs)])
      | Just Name
n <- Maybe Name
nameClass, TyCon -> Name
tyConName TyCon
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n =
        [ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
Just [ByteString -> ByteString
substDollar (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ FastString -> ByteString
FastString.Extras.bytesFS FastString
fs]
      | Just Name
n <- Maybe Name
nameIface, TyCon -> Name
tyConName TyCon
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n =
        [ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
Just [ByteString -> ByteString
substDollar (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ FastString -> ByteString
FastString.Extras.bytesFS FastString
fs]
    go (TyConApp TyCon
c [Type
t])
      | Just Name
n <- Maybe Name
nameArray, TyCon -> Name
tyConName TyCon
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n =
        ([ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
"[]"]) ([ByteString] -> [ByteString])
-> Maybe [ByteString] -> Maybe [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe [ByteString]
go Type
t
    go (TyConApp TyCon
c [Type
t, Type
ts])
      | Just Name
n <- Maybe Name
nameGeneric, TyCon -> Name
tyConName TyCon
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n = do
        [ByteString]
bs <- Type -> Maybe [ByteString]
go Type
t
        [[ByteString]]
args_ts <- Type -> Maybe [[ByteString]]
listGo Type
ts
        [ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
Just ([ByteString] -> Maybe [ByteString])
-> [ByteString] -> Maybe [ByteString]
forall a b. (a -> b) -> a -> b
$ [ByteString]
bs [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ ByteString
"<" ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([ByteString] -> [[ByteString]] -> [[ByteString]]
forall a. a -> [a] -> [a]
intersperse [ByteString
","] [[ByteString]]
args_ts) [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
">"]
    go (TyConApp TyCon
c [])
      | Just Name
n <- Maybe Name
nameVoid, TyCon -> Name
tyConName TyCon
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n =
        [ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
Just [ByteString
"void"]
    go (TyConApp TyCon
c [LitTy (StrTyLit FastString
fs)])
      | Just Name
n <- Maybe Name
namePrim, TyCon -> Name
tyConName TyCon
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n =
        [ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
Just [FastString -> ByteString
FastString.Extras.bytesFS FastString
fs]
    go Type
_ = Maybe [ByteString]
forall a. Maybe a
Nothing

    listGo :: Type -> Maybe [[BS.ByteString]]
    listGo :: Type -> Maybe [[ByteString]]
listGo (TyConApp TyCon
c [Type
_]) | Name
nilDataConName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Name
tyConName TyCon
c = [[ByteString]] -> Maybe [[ByteString]]
forall a. a -> Maybe a
Just []
    listGo (TyConApp TyCon
c [Type
_, Type
tx, Type
txs]) | Name
consDataConName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Name
tyConName TyCon
c =
      (:) ([ByteString] -> [[ByteString]] -> [[ByteString]])
-> Maybe [ByteString] -> Maybe ([[ByteString]] -> [[ByteString]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe [ByteString]
go Type
tx Maybe ([[ByteString]] -> [[ByteString]])
-> Maybe [[ByteString]] -> Maybe [[ByteString]]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe [[ByteString]]
listGo Type
txs
    listGo Type
_ = Maybe [[ByteString]]
forall a. Maybe a
Nothing

    -- Substitutes '$' with '.' in java names.
    substDollar :: BS.ByteString -> BS.ByteString
    substDollar :: ByteString -> ByteString
substDollar ByteString
xs
      | Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'$') Word8 -> ByteString -> Bool
`BS.elem` ByteString
xs =
        let subst :: p -> p
subst (Int -> Char
chr (Int -> Char) -> (p -> Int) -> p -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Char
'$') = Int -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'.')
            subst p
x = p
x
         in (Word8 -> Word8) -> ByteString -> ByteString
BS.map Word8 -> Word8
forall p. Integral p => p -> p
subst ByteString
xs
      | Bool
otherwise = ByteString
xs

-- | An occurrence of a java quasiquotation
data QQOcc = QQOcc
    { -- | The type of the result
      QQOcc -> Type
qqOccResTy :: Type
      -- | The type of the arguments
    , QQOcc -> [Type]
qqOccArgTys :: [Type]
      -- | The input of the quasiquoter
    , QQOcc -> ByteString
qqOccInput :: BS.ByteString
      -- | The name of the method to generate
    , QQOcc -> ByteString
qqOccMName :: BS.ByteString
      -- | The antiquotations of the quasiquoter
    , QQOcc -> ByteString
qqOccAntiQs :: BS.ByteString
      -- | The line number where the quasiquotation appears
    , QQOcc -> Integer
qqOccLineNumber :: Integer
    }

-- | A monad for collecting qqMarker occurrences.
type QQJavaM a = WriterT (Endo [QQOcc]) CoreM a

-- Collects the occurrences of qqMarkers.
--
-- The program is expected to have 'qqMarker' occurrences inserted
-- by the java quasiquoter.
--
-- > module A where
-- > import Language.Java.Inline
-- >
-- > f = ...
-- >     (qqMarker ... (callStatic "Inline__<pkg>_<mod>" "inline__method_i" []))
-- >     ...
-- >
-- > g = ...
-- > ...
--
-- 'collectQQMarkers' yields one 'QQOcc' value for every occurrence of
-- 'qqMarker', and the program resulting from removing the markers.
--
-- > module A where
-- > import Language.Java.Inline
-- >
-- > f = ...
-- >     (callStatic "Inline__<pkg>_<mod>" "inline__method_i" [])
-- >     ...
-- >
-- > g = ...
-- > ...
--
collectQQMarkers
  :: [Name] -> CoreProgram -> CoreM (CoreProgram, [QQOcc])
collectQQMarkers :: [Name] -> CoreProgram -> CoreM (CoreProgram, [QQOcc])
collectQQMarkers [Name]
qqMarkerNames CoreProgram
p0 = do
    (CoreProgram
p1, Endo [QQOcc]
e) <- WriterT (Endo [QQOcc]) CoreM CoreProgram
-> CoreM (CoreProgram, Endo [QQOcc])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT ((CoreBind -> WriterT (Endo [QQOcc]) CoreM CoreBind)
-> CoreProgram -> WriterT (Endo [QQOcc]) CoreM CoreProgram
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CoreBind -> WriterT (Endo [QQOcc]) CoreM CoreBind
bindMarkers CoreProgram
p0)
    (CoreProgram, [QQOcc]) -> CoreM (CoreProgram, [QQOcc])
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreProgram
p1, Endo [QQOcc] -> [QQOcc] -> [QQOcc]
forall a. Endo a -> a -> a
appEndo Endo [QQOcc]
e [])
  where
    bindMarkers :: CoreBind -> QQJavaM CoreBind
    bindMarkers :: CoreBind -> WriterT (Endo [QQOcc]) CoreM CoreBind
bindMarkers (NonRec CoreBndr
b Expr CoreBndr
e) = CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b (Expr CoreBndr -> CoreBind)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
expMarkers Expr CoreBndr
e
    bindMarkers (Rec [(CoreBndr, Expr CoreBndr)]
bs) = [(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(CoreBndr, Expr CoreBndr)] -> CoreBind)
-> WriterT (Endo [QQOcc]) CoreM [(CoreBndr, Expr CoreBndr)]
-> WriterT (Endo [QQOcc]) CoreM CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((CoreBndr, Expr CoreBndr)
 -> WriterT (Endo [QQOcc]) CoreM (CoreBndr, Expr CoreBndr))
-> [(CoreBndr, Expr CoreBndr)]
-> WriterT (Endo [QQOcc]) CoreM [(CoreBndr, Expr CoreBndr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(CoreBndr
b, Expr CoreBndr
e) -> (,) CoreBndr
b (Expr CoreBndr -> (CoreBndr, Expr CoreBndr))
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (CoreBndr, Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
expMarkers Expr CoreBndr
e) [(CoreBndr, Expr CoreBndr)]
bs

    expMarkers :: CoreExpr -> QQJavaM CoreExpr
    expMarkers :: Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
expMarkers (App (App (App (App (App (App (App (App (App (App (App (App (App
                 (App (App (App (App (App (App (App (App (Var CoreBndr
fid) Expr CoreBndr
_)
                 (Type (Type -> Maybe [Type]
parseArgTys -> Just [Type]
tyargs)))
                 (Type Type
tyres))
                 (Type (LitTy (StrTyLit FastString
fs_input))))
                 (Type (LitTy (StrTyLit FastString
fs_mname))))
                 (Type (LitTy (StrTyLit FastString
fs_antiqs))))
                 (Type (LitTy (NumTyLit Integer
lineNumber))))
                 Expr CoreBndr
_) Expr CoreBndr
_) Expr CoreBndr
_) Expr CoreBndr
_) Expr CoreBndr
_) Expr CoreBndr
_) Expr CoreBndr
_) Expr CoreBndr
_) Expr CoreBndr
_) Expr CoreBndr
_) Expr CoreBndr
_) Expr CoreBndr
args) Expr CoreBndr
_)
                 Expr CoreBndr
e
               )
        | Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (CoreBndr -> Name
idName CoreBndr
fid) [Name]
qqMarkerNames = do
      Endo [QQOcc] -> WriterT (Endo [QQOcc]) CoreM ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Endo [QQOcc] -> WriterT (Endo [QQOcc]) CoreM ())
-> Endo [QQOcc] -> WriterT (Endo [QQOcc]) CoreM ()
forall a b. (a -> b) -> a -> b
$ ([QQOcc] -> [QQOcc]) -> Endo [QQOcc]
forall a. (a -> a) -> Endo a
Endo (([QQOcc] -> [QQOcc]) -> Endo [QQOcc])
-> ([QQOcc] -> [QQOcc]) -> Endo [QQOcc]
forall a b. (a -> b) -> a -> b
$ (:) (QQOcc -> [QQOcc] -> [QQOcc]) -> QQOcc -> [QQOcc] -> [QQOcc]
forall a b. (a -> b) -> a -> b
$ QQOcc :: Type
-> [Type]
-> ByteString
-> ByteString
-> ByteString
-> Integer
-> QQOcc
QQOcc
        { qqOccResTy :: Type
qqOccResTy = Type
tyres
        , qqOccArgTys :: [Type]
qqOccArgTys = [Type]
tyargs
        , qqOccInput :: ByteString
qqOccInput = FastString -> ByteString
FastString.Extras.bytesFS FastString
fs_input
        , qqOccMName :: ByteString
qqOccMName = FastString -> ByteString
FastString.Extras.bytesFS FastString
fs_mname
        , qqOccAntiQs :: ByteString
qqOccAntiQs = FastString -> ByteString
FastString.Extras.bytesFS FastString
fs_antiqs
        , qqOccLineNumber :: Integer
qqOccLineNumber = Integer
lineNumber
        }
      Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App Expr CoreBndr
e Expr CoreBndr
args)
    expMarkers (Var CoreBndr
fid) | Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (CoreBndr -> Name
idName CoreBndr
fid) [Name]
qqMarkerNames =
      CoreM (Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CoreM (Expr CoreBndr)
 -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr))
-> CoreM (Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM (Expr CoreBndr)
forall a. SDoc -> CoreM a
GhcPlugins.Extras.failWith (SDoc -> CoreM (Expr CoreBndr)) -> SDoc -> CoreM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$
      CommandLineOption -> SDoc
text CommandLineOption
"inline-java Plugin: found invalid qqMarker."
    expMarkers (App Expr CoreBndr
e Expr CoreBndr
a) = Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App (Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr -> Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
expMarkers Expr CoreBndr
e WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr -> Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
expMarkers Expr CoreBndr
a
    expMarkers (Lam CoreBndr
b Expr CoreBndr
e) = CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
b (Expr CoreBndr -> Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
expMarkers Expr CoreBndr
e
    expMarkers (Let CoreBind
bnd Expr CoreBndr
e) = CoreBind -> Expr CoreBndr -> Expr CoreBndr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBind -> Expr CoreBndr -> Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM CoreBind
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr -> Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreBind -> WriterT (Endo [QQOcc]) CoreM CoreBind
bindMarkers CoreBind
bnd WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr -> Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
expMarkers Expr CoreBndr
e
    expMarkers (Case Expr CoreBndr
e0 CoreBndr
b Type
t [Alt CoreBndr]
alts) = do
      Expr CoreBndr
e0' <- Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
expMarkers Expr CoreBndr
e0
      let expAlt :: (a, b, Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (a, b, Expr CoreBndr)
expAlt (a
a, b
bs, Expr CoreBndr
e) = (,,) a
a b
bs (Expr CoreBndr -> (a, b, Expr CoreBndr))
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (a, b, Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
expMarkers Expr CoreBndr
e
      [Alt CoreBndr]
alts' <- (Alt CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Alt CoreBndr))
-> [Alt CoreBndr] -> WriterT (Endo [QQOcc]) CoreM [Alt CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Alt CoreBndr)
forall a b.
(a, b, Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (a, b, Expr CoreBndr)
expAlt [Alt CoreBndr]
alts
      Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr
-> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr CoreBndr
e0' CoreBndr
b Type
t [Alt CoreBndr]
alts')
    expMarkers (Cast Expr CoreBndr
e Coercion
c) = (Expr CoreBndr -> Coercion -> Expr CoreBndr)
-> Coercion -> Expr CoreBndr -> Expr CoreBndr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr CoreBndr -> Coercion -> Expr CoreBndr
forall b. Expr b -> Coercion -> Expr b
Cast Coercion
c (Expr CoreBndr -> Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
expMarkers Expr CoreBndr
e
    expMarkers (Tick Tickish CoreBndr
t Expr CoreBndr
e) = Tickish CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Tickish CoreBndr -> Expr b -> Expr b
Tick Tickish CoreBndr
t (Expr CoreBndr -> Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
-> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
expMarkers Expr CoreBndr
e
    expMarkers e :: Expr CoreBndr
e@(Coercion {}) = Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
e
    expMarkers e :: Expr CoreBndr
e@(Lit {}) = Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
e
    expMarkers e :: Expr CoreBndr
e@(Var {}) = Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
e
    expMarkers e :: Expr CoreBndr
e@(Type {}) = Expr CoreBndr -> WriterT (Endo [QQOcc]) CoreM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
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 :: Type -> Maybe [Type]
parseArgTys (TyConApp TyCon
c [Type
_, Type
_, Type
ty, Type
tys])
      | TyCon
c TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== Boxity -> Int -> TyCon
promotedTupleDataCon Boxity
Boxed Int
2 =
        (Type
tyType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:) ([Type] -> [Type]) -> Maybe [Type] -> Maybe [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe [Type]
parseArgTys Type
tys
    parseArgTys (TyConApp TyCon
c [])
      | TyCon
c TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon =
        [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just []
    parseArgTys Type
_ = Maybe [Type]
forall a. Maybe a
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 :: [DotClass] -> SDoc
dotClasses [DotClass]
dcs = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
      CommandLineOption -> SDoc
text CommandLineOption
"static int dc_count =" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int ([DotClass] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DotClass]
dcs) SDoc -> SDoc -> SDoc
<> SDoc
semi
    SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [ [SDoc] -> SDoc
vcat
        [ CommandLineOption -> SDoc
text CommandLineOption
"static unsigned char bc" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i SDoc -> SDoc -> SDoc
<> CommandLineOption -> SDoc
text CommandLineOption
"[] ="
        , SDoc -> SDoc
braces ((Word8 -> SDoc) -> [Word8] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (CommandLineOption -> SDoc
text (CommandLineOption -> SDoc)
-> (Word8 -> CommandLineOption) -> Word8 -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show) (ByteString -> [Word8]
BS.unpack ByteString
bc)) SDoc -> SDoc -> SDoc
<> SDoc
semi
        ]
      | (Int
i, DotClass CommandLineOption
_ ByteString
bc) <- [Int] -> [DotClass] -> [(Int, DotClass)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [DotClass]
dcs
      ]
      [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
      [ CommandLineOption -> SDoc
text CommandLineOption
"static struct inline_java_dot_class dcs[] ="
      , SDoc -> SDoc
braces
          (((Int, DotClass) -> SDoc) -> [(Int, DotClass)] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas
            (\(Int
i, DotClass CommandLineOption
name ByteString
bc) ->
               SDoc -> SDoc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ (SDoc -> SDoc) -> [SDoc] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas SDoc -> SDoc
forall a. a -> a
id
                 [ CommandLineOption -> SDoc
text (CommandLineOption -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show CommandLineOption
name), Int -> SDoc
int (ByteString -> Int
BS.length ByteString
bc), CommandLineOption -> SDoc
text CommandLineOption
"bc" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i])
            ([Int] -> [DotClass] -> [(Int, DotClass)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [DotClass]
dcs)
          ) SDoc -> SDoc -> SDoc
<> SDoc
semi
      ]

-- | Produces the constructor function which inserts the static structures
-- generated by 'dotClasses' into the bytecode table.
cConstructors :: SDoc
cConstructors :: SDoc
cConstructors = [SDoc] -> SDoc
vcat
    [ CommandLineOption -> SDoc
text CommandLineOption
"static void hs_inline_java_init(void) __attribute__((constructor));"
    , CommandLineOption -> SDoc
text CommandLineOption
"static void hs_inline_java_init(void)"
    , CommandLineOption -> SDoc
text CommandLineOption
"{ inline_java_bctable = inline_java_new_pack(inline_java_bctable, dcs, dc_count); }"
    ]