j2hs-0.99: src/CodeGen/JavaBindings.hss
{-# LANGUAGE Haskell2010, FlexibleContexts #-}
-- {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
-- | Functions for generating glue code between Haskell and Java.
module CodeGen.JavaBindings where
import CodeGen.Class
import CodeGen.Typomatic
import Types
import Utils
import qualified Haskell.X as X
import Haskell.X.Unsafe
import Haskell.X.Ops
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Data.Function
import qualified Data.List as L
import qualified Data.Char as C
imports :: Monad m => CodeGenerator m
-- ^ Imports of all auto generated java code files.
imports = do
return """
import qualified Foreign.Java as JNI
import Foreign.Java ((-->))
import qualified Prelude as P
import Prelude ((.), ($), (>>=), (>>), return)
import qualified Foreign.Java.Bindings as JNIS
import Data.Functor ((<$>))
"""
javaPackageModule :: Monad m => String -> CodeGenerator m
-- ^ java.lang -> Java.Lang (package hierarchy)
javaPackageModule packageName = do
commonImports <- imports
deps <- getPackageModuleDeps packageName
moduleName <- getModNameForPackage packageName
moduleComment <- return """The @#{packageName}@ package."""
moduleImports <- return deps
>>= return . concatMap (\name -> "import " ++ name ++ "__\n")
moduleExports <- return deps
>>= return . concat . L.intersperse ",\n" . map (\x -> "module " ++ x ++ "__")
return """
{-# LANGUAGE Haskell2010 #-}
-- | #{moduleComment}
module #{moduleName} (
#{moduleExports}\
) where
#{commonImports}
#{moduleImports}
"""
readArg :: String -> JavaType -> String
readArg name jtype = case jtype of
JBoolean -> """#{name}' <- JNIS.toBoolean #{name}\n"""
JChar -> """#{name}' <- JNIS.toChar #{name}\n"""
JByte -> """#{name}' <- JNIS.toByte #{name}\n"""
JShort -> """#{name}' <- JNIS.toShort #{name}\n"""
JInt -> """#{name}' <- JNIS.toInt #{name}\n"""
JLong -> """#{name}' <- JNIS.toLong #{name}\n"""
JFloat -> """#{name}' <- JNIS.toFloat #{name}\n"""
JDouble -> """#{name}' <- JNIS.toDouble #{name}\n"""
JObj _ -> """#{name}' <- P.Just <$> JNI.asObject #{name}\n"""
JArr _ -> """#{name}' <- JNIS.asMaybeArrayObject #{name}\n"""
convertResult :: Maybe JavaType -> String
convertResult rtype = case rtype of
Nothing -> "JNIS.toVoidResult"
Just t -> case t of
JBoolean -> "JNIS.toBooleanResult"
JChar -> "JNIS.toCharResult"
JByte -> "JNIS.toByteResult"
JShort -> "JNIS.toShortResult"
JInt -> "JNIS.toIntResult"
JLong -> "JNIS.toLongResult"
JFloat -> "JNIS.toFloatResult"
JDouble -> "JNIS.toDoubleResult"
JObj n -> "JNIS.toObjectResult"
JArr c -> "(\\x -> let (P.Right (P.Just y)) = x in return y)"
javaClassModule :: (Functor m, Monad m) => String -> CodeGenerator m
-- ^ java.lang.Thread -> Java.Lang.Thread (implementation file)
javaClassModule className = do
clazz <- getClassInfoFor className
commonImports <- imports
moduleName <- getModNameForClass className
let baseName = takeClassName moduleName
isIface = classIface clazz
moduleImports <- getClassModuleDeps clazz
>>= return . concatMap (\name -> "import qualified " ++ name ++ "__\n")
let mkConstructorNames :: [JavaConstructor] -> [String]
mkConstructorNames = zipWith (flip (++)) (iterate (++"'") "") . map (const $ "new'" ++ baseName)
mkMethodNames :: [JavaMethod] -> [String]
mkMethodNames = concatMap (zipWith (flip (++)) (iterate (++"'") ""))
. L.group . map sanitize . map methodName
where
sanitize name
| C.isUpper (head name) = '_' : name
| name `elem` haskellKeywords = name ++ "'"
| otherwise = name
mkFields :: [JavaField] -> [(JavaField, (String, Maybe String))]
mkFields = map mkField . L.nubBy ((==) `on` fieldName)
where
mkField f = (f, ("get'" ++ name, (if fieldFinal f then Nothing else Just ("set'" ++ name))))
where name = fieldName f
methods_ = L.sortBy (compare `on` methodName) (classMethods clazz)
constrs_ = L.sortBy compareConstructors (classConstructors clazz)
compareConstructors a b = length (constructorParams a) `compare` length (constructorParams b)
constrNames <- constrs_ =>> mkConstructorNames
methodNames <- methods_ =>> mkMethodNames
constrs <- constrNames =>> zip constrs_
methods <- methodNames =>> zip methods_
fields <- (classFields clazz) =>> mkFields
let (constrNames, fieldNames, methodNames)
= (map snd constrs,
concatMap (\(_, (g, s)) -> g : maybe [] (:[]) s) fields,
map snd methods)
functions = concat [constrNames, fieldNames, methodNames]
ifaceConstructor = """new'#{baseName}"""
constructors
| classIface clazz = """
-- * Constructors
#{ifaceConstructor},
\n"""
| otherwise = """
-- * Constructors
#{if null constrs then '-':"- | No Constructors!" else concatMap (++ ",\n") constrNames}
\n"""
moduleComment <- return ""
moduleExports <- return """
#{constructors}
-- * Fields
#{if null fields then '-':"- | No Fields!" else concatMap (++ ",\n") fieldNames}
-- * Methods
#{if null methods then '-':"- | No Methods!" else concat $ L.intersperse ",\n" methodNames}
"""
infoFunc <- getClassInfoFunc
modFunc <- getClassModFunc
constrDeclarations <- case classIface clazz of
True -> return """
#{ifaceConstructor} :: a
#{ifaceConstructor} = P.undefined
\n"""
False -> fmap concat $ forM constrs $ \(constr, name) -> do
let argsInfo = runTypomatic infoFunc (constructorType clazz constr modFunc)
args = fArgNames argsInfo
readArgs = concatMap ((" " ++) . uncurry readArg)
(zip args (map fst $ constructorParams constr))
preamble = """
#{name} :: #{fSignature argsInfo}
#{name}#{concatMap (' ':) args} = do
(P.Just clazz) <- JNI.getClass "#{className}"
"""
case constructorParams constr of
[] -> return """
#{preamble}
JNI.newObjectE clazz >>= JNIS.toObjectResult
\n"""
_ -> return """
#{preamble}
(P.Just constr) <- JNI.getConstructor clazz $ #{fJniSignature argsInfo}
#{readArgs}\
result <- JNI.newObjectFromE constr #{concatMap (++ "' ") args}
JNIS.toObjectResult result
\n"""
methodDeclarations <- fmap concat $ forM methods $ \(method, name) -> do
let isStatic = methodStatic method
getMethod = if isStatic then "getStaticMethod" else "getMethod"
callMethod = if isStatic then "callStaticMethodE" else "callMethodE"
argsInfo = runTypomatic infoFunc (methodType clazz method modFunc)
args = fArgNames argsInfo
argsNotThis = (if isStatic then id else tail) args
haddock = """
@#{if isStatic then "static " else "virtual "}\
#{if methodSynchronized method then "synchronized " else ""}\
#{if methodNative method then "native " else ""}\
#{if methodFinal method then "final " else ""}\
#{fJavaSignature argsInfo} -> #{fJavaReturnType argsInfo}@"""
thisArg = if isStatic then "" else """ #{head args}' <- JNI.asObject #{head args}\n"""
readArgs = concatMap ((" " ++) . uncurry readArg)
(zip argsNotThis (map fst $ methodParams method))
return """
{- | #{haddock} -}
#{name} :: #{fSignature argsInfo}
#{name}#{concatMap (' ':) args} = do
(P.Just clazz) <- JNI.getClass "#{className}"
(P.Just method) <- clazz `JNI.#{getMethod}` #{fJniSignature argsInfo}
#{thisArg}\
#{readArgs}\
result <- JNI.#{callMethod} method #{concatMap (++ "' ") args}
#{convertResult (fst (methodReturnType method))} result
\n"""
fieldDeclarations <- fmap concat $ forM fields $ \(field, (getterName, setterName)) -> do
let isStatic = fieldStatic field
jniType = printJniType $ fst $ fieldType field
(getField, readField, writeField) = case isStatic of
True -> ("getStaticField", "readStaticField", "writeStaticField")
False -> ("getField", "readField", "writeField")
getterInfo = runTypomatic infoFunc (getterType clazz field modFunc)
setterInfo = runTypomatic infoFunc (setterType clazz field modFunc)
getterArgs = fArgNames getterInfo
getterArgsNotThis = (if isStatic then id else tail) getterArgs
setterArgs = fArgNames setterInfo
setterArgsNotThis = (if isStatic then id else tail) setterArgs
thisArg = if isStatic then ""
else """ #{head getterArgs}' <- JNI.asObject #{head getterArgs}\n"""
getter = """
#{getterName} :: #{fSignature getterInfo}
#{getterName}#{concatMap (' ':) getterArgs} = do
(P.Just clazz) <- JNI.getClass "#{className}"
(P.Just field) <- JNI.#{getField} clazz "#{fieldName field}" (#{jniType})
#{thisArg}\
result <- JNI.#{readField} field #{concatMap (++ "' ") getterArgs}
#{convertResult (Just (fst (fieldType field)))} (P.Right result)
\n"""
setter
| (Just name) <- setterName = """
#{name} :: #{fSignature setterInfo}
#{name}#{concatMap (' ':) setterArgs} = do
(P.Just clazz) <- JNI.getClass "#{className}"
(P.Just field) <- JNI.#{getField} clazz "#{fieldName field}" (#{jniType})
#{thisArg}\
JNI.#{writeField} field #{concatMap (++ "' ") setterArgs}
return ()
\n"""
| otherwise = ""
return $ getter ++ setter
return """
{-# LANGUAGE Haskell2010 #-}
-- | #{moduleComment}
module #{moduleName} (
#{moduleExports}\
) where
#{commonImports}
#{moduleImports}
#{constrDeclarations}
#{methodDeclarations}
#{fieldDeclarations}
"""
javaClassModule' :: (Functor m, Monad m) => String -> CodeGenerator m
-- ^ java.lang.Thread -> Java.Lang.Thread__ (interface file)
javaClassModule' className = do
clazz <- getClassInfoFor className
moduleName <- getModNameForClass className
baseName <- moduleName =>> takeClassName
commonImports <- imports
moduleImports <- getClassModulesUniq (classParents clazz ++ classIfaces clazz)
>>= return . concatMap (\name -> "import qualified " ++ name ++ "__\n")
moduleComment <- return """See "#{moduleName}" for the available methods."""
let params = concatMap (\(p:ps) -> ' ' : C.toLower p : ps)
$ map (tyVarName . paramName) $ classTypeParams clazz
newtTDecl = newtTName baseName ++ params
newtCDecl = newtCName baseName
dataTDecl = dataTName baseName ++ params
dataCDecl = dataCName baseName ++ params
parentInstance parent = do
modName <- getModNameForClass parent
let qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName)
return """instance #{qualifiedName} (#{newtTDecl})\n"""
parentContext parent = do
modName <- getModNameForClass parent
let qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName)
return """, #{qualifiedName} this"""
context <- concat <$> mapM parentContext (classParents clazz)
instances <- concat <$> mapM parentInstance (classParents clazz)
let tyclTDecl = """(JNI.JavaObject this#{context}) => #{tyclTName baseName} this"""
enumConstants = map sanitize $ map snd $ classEnumConstants clazz
where sanitize (x:xs) = C.toUpper x : xs
newtAdditions
| classEnum clazz = enumConstants
| otherwise = []
newtDeclaration
| null newtAdditions = """newtype #{newtTDecl} = #{newtCDecl} JNI.JObject"""
| otherwise = """data #{newtTDecl} = #{newtCDecl} JNI.JObject"""
++ concatMap (" | " ++ ) newtAdditions
newtExport
| null newtAdditions = ""
| otherwise = concat (" (" : L.intersperse ", " newtAdditions ++ [")"])
moduleExports = """
#{tyclTName baseName},
#{dataTName baseName} (..),
#{newtTName baseName}#{newtExport},
"""
javaObjectInstance
| classEnum clazz = """
instance JNI.JavaObject (#{newtTDecl}) where
asObject (#{newtCName baseName} obj) = return obj
#{concatMap (uncurry asObjectMatch) $ zip enumConstants $ classEnumConstants clazz}"""
| otherwise = """
instance JNI.JavaObject (#{newtTDecl}) where
asObject (#{newtCName baseName} obj) = return obj"""
where
asObjectMatch enum (ord, name) = """
asObject #{enum} = do
-- #{show ord}, #{name}
(P.Just clazz) <- JNI.getClass "#{className}"
(P.Just field) <- JNI.getStaticField clazz "#{name}" (JNI.object "#{className}")
(P.Just object) <- JNI.readStaticField field
return object
"""
moduleDeclarations = """
class #{tyclTDecl}
#{newtDeclaration}
data #{dataTDecl} = #{dataCDecl}
#{javaObjectInstance}
instance JNIS.UnsafeCast (#{newtTDecl}) where
unsafeFromJObject obj = return (#{newtCDecl} obj)
instance #{tyclTName baseName} (#{newtTDecl})
instance JNIS.InstanceOf (#{dataTDecl}) where
type CoercedType (#{dataTDecl}) = (#{newtTDecl})
coerce o t = do
obj <- JNI.asObject o
(P.Just clazz) <- JNI.getClass "#{className}"
isInstanceOf <- obj `JNI.isInstanceOf` clazz
if isInstanceOf
then P.Just <$> (JNIS.unsafeFromJObject obj)
else return P.Nothing
#{instances}
"""
additionalDeclarations <- case className of
"java.lang.String" -> return """
instance JNI.JavaObject [P.Char] where
asObject s = do
(P.Just clazz) <- JNI.getClass "java.lang.String"
(P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf" ::= JNI.string --> JNI.object "java.lang.String"
(P.Just string) <- JNI.callStaticMethod valueOf s
JNI.asObject string
instance Java.Lang.Object [P.Char]
instance Java.Lang.String [P.Char]
"""
"java.lang.Character" -> return """
instance JNI.JavaObject P.Char where
asObject ...
instance Java.Lang.Object P.Char
instance Java.Lang.Character P.Char
"""
"java.lang.Boolean" -> return """
instance JNI.JavaObject P.Bool where
asObject n = do
(P.Just clazz) <- JNI.getClass "java.lang.Boolean"
(P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf"
::= JNI.byte --> JNI.object "java.lang.Boolean"
(P.Just boolean) <- JNI.callStaticMethod valueOf n
JNI.asObject boolean
instance Java.Lang.Object P.Bool
instance Java.Lang.Boolean P.Bool
"""
"java.lang.Number" -> return """
import qualified Data.Int
import qualified Data.Word
instance JNI.JavaObject Data.Int.Int8 where
asObject n = do
(P.Just clazz) <- JNI.getClass "java.lang.Byte"
(P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf"
::= JNI.byte --> JNI.object "java.lang.Byte"
(P.Just number) <- JNI.callStaticMethod valueOf n
JNI.asObject number
instance JNI.JavaObject Data.Int.Int16 where
asObject n = do
(P.Just clazz) <- JNI.getClass "java.lang.Short"
(P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf"
::= JNI.short --> JNI.object "java.lang.Short"
(P.Just number) <- JNI.callStaticMethod valueOf n
JNI.asObject number
instance JNI.JavaObject Data.Int.Int32 where
asObject n = do
(P.Just clazz) <- JNI.getClass "java.lang.Integer"
(P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf"
::= JNI.int --> JNI.object "java.lang.Integer"
(P.Just number) <- JNI.callStaticMethod valueOf n
JNI.asObject number
instance JNI.JavaObject Data.Int.Int64 where
asObject n = do
(P.Just clazz) <- JNI.getClass "java.lang.Long"
(P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf"
::= JNI.long --> JNI.object "java.lang.Long"
(P.Just number) <- JNI.callStaticMethod valueOf n
JNI.asObject number
instance Java.Lang.Object P.Int
instance Java.Lang.Number P.Int
instance Java.Lang.Object Data.Int.Int8
instance Java.Lang.Number Data.Int.Int8
instance Java.Lang.Object Data.Int.Int16
instance Java.Lang.Number Data.Int.Int16
instance Java.Lang.Object Data.Int.Int32
instance Java.Lang.Number Data.Int.Int32
instance Java.Lang.Object Data.Int.Int64
instance Java.Lang.Number Data.Int.Int64
"""
"java.lang.Byte" -> return """
import qualified Data.Int
import qualified Data.Word
instance Java.Lang.Byte Data.Int
"""
"java.lang.Short" -> return """
import qualified Data.Int
import qualified Data.Word
instance Java.Lang.Short Data.Int
"""
"java.lang.Integer" -> return """
import qualified Data.Int
import qualified Data.Word
instance Java.Lang.Integer Data.Int
"""
"java.lang.Long" -> return """
import qualified Data.Int
import qualified Data.Word
instance Java.Lang.Long Data.Int
"""
"java.lang.Float" -> return """
import qualified Data.Int
import qualified Data.Word
instance Java.Lang.Float Data.Int
"""
"java.lang.Double" -> return """
import qualified Data.Int
import qualified Data.Word
instance Java.Lang.Double Data.Int
"""
return """
{-# LANGUAGE Haskell2010, TypeFamilies, FlexibleInstances #-}
-- | #{moduleComment}
module #{moduleName}__ (
#{moduleExports}
) where
#{commonImports}
#{moduleImports}
#{additionalDeclarations}
#{moduleDeclarations}
"""