{-# 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 ((<>))
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
[] -> 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
}
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)
)
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
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
]
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))
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]
[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)
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
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
}
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
..}
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
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
data QQOcc = QQOcc
{
QQOcc -> Type
qqOccResTy :: Type
, QQOcc -> [Type]
qqOccArgTys :: [Type]
, QQOcc -> ByteString
qqOccInput :: BS.ByteString
, QQOcc -> ByteString
qqOccMName :: BS.ByteString
, QQOcc -> ByteString
qqOccAntiQs :: BS.ByteString
, QQOcc -> Integer
qqOccLineNumber :: Integer
}
type QQJavaM a = WriterT (Endo [QQOcc]) CoreM a
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 :: 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
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
]
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); }"
]