{-# LANGUAGE Haskell2010 #-} module Foreign.Java.Bindings.Java2Haskell where import Foreign.Java.Util import Foreign.Java.Utils import Foreign.Java.Bindings.JavaTypes import Foreign.Java.Bindings.Typomatic import Data.Map (Map) import Data.Function import qualified Data.Char as Char import qualified Data.List as List import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.List.HIUtils as HI import Control.Arrow pkgModExports :: Map String JavaClass -> [JavaClass] -> String pkgModExports info classes = concatMap (\(t, b) -> """ -- * #{show t}s\n#{b}""") $ map (second $ concatMap format) $ HI.aggregateAL $ zip (map classType classes) classes where format clazz = let haskName = takeClassName $ classModName clazz javaName = className clazz dataDecl = if classIface clazz then "" else """ #{dataTName haskName} (..),\n""" in """ -- ** #{show $ classType clazz} #{javaName} -- | For constructors, methods, and so on, see: "#{classModName clazz}". #{tyclTName haskName}, #{dataDecl}\ #{newtTName haskName} #{if classEnum clazz then "(..)" else ""}, """ pkgModImports :: Map String JavaClass -> [JavaClass] -> String pkgModImports info classes = concatMap (format . classModName) classes where format modName = """import #{modName}__ hiding (info')\n""" pkgModDecl :: Map String JavaClass -> [JavaClass] -> String pkgModDecl info classes = "" -- Modules and Boot files classBootExports :: Map String JavaClass -> JavaClass -> String classBootExports info clazz = "" classBootImports :: Map String JavaClass -> JavaClass -> String classBootImports info clazz = "" classModImports :: Map String JavaClass -> JavaClass -> String classModImports info clazz = concatMap format references where format package = """import qualified #{package}\n""" references = Set.toList $ Set.map (fst . splitClassName . classModName . check . flip Map.lookup info) $ Set.fromList (classFullName clazz : dependencies) dependencies = classDependencies clazz check = maybe (error """ classModImports in Foreign.Java.Bindings.Java2Haskell \ - class definition not found""") id classBootDecl :: Map String JavaClass -> JavaClass -> String classBootDecl info clazz = """ """ classModExports :: Map String JavaClass -> JavaClass -> String classModExports info clazz = " -- * Methods\n" ++ concatMap methodExport methodNames where methods = List.sortBy (compare `on` methodName) (classMethods clazz) methodNames = mkMethodNames methods methodExport name = name ++ ", \n" classModDecl :: Map String JavaClass -> JavaClass -> String classModDecl info clazz = concatMap methodDecl $ zip methodNames methods where methods = List.sortBy (compare `on` methodName) (classMethods clazz) methodNames = mkMethodNames methods methodDecl (name, method) | arrayTypes = """ #{name} :: #{signature} #{name} = Prelude.undefined """ | otherwise = """ #{haddock} #{name} :: #{signature} #{name}#{argsDecl} = do (Prelude.Just clazz) <- JNI.getClass "#{classFullName clazz}" (Prelude.Just method) <- clazz `JNI.#{getMethod}` #{jniSignature} #{thisArg}\ #{readArgs}\ result <- JNI.#{callMethod} method #{argsRefs} #{convertResult} result """ where arrayTypes -- | any isArrayType (methodParams method) = True | (Just ret) <- methodReturnType method = isArrayType ret | otherwise = False isArrayType x = case x of JArr _ -> True ; _ -> False isStatic = methodStatic method javaSignature = fJavaSignature argsInfo javaReturnType = fJavaReturnType argsInfo jniSignature = fJniSignature argsInfo signature = fSignature argsInfo getMethod = if isStatic then "getStaticMethod" else "getMethod" callMethod = if isStatic then "callStaticMethodE" else "callMethodE" args = fArgNames argsInfo argsNotThis = (if isStatic then id else tail) args argsInfo = runTypomatic info (typomatic clazz method) argsDecl = concatMap (' ':) args argsRefs = concatMap (++ "' ") 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 ""}\ #{javaSignature} -> #{javaReturnType}@""" thisArg = if isStatic then "" else """ #{head args}' <- JNI.asObject #{head args}\n""" readArgs = concatMap ((" " ++). uncurry readArg) (zip argsNotThis (methodParams method)) 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}' <- Prelude.Just <$> JNI.asObject #{name}\n""" JArr _ -> """#{name}' <- JNIS.asMaybeArrayObject #{name}\n""" convertResult = ("JNIS." ++) $ case methodReturnType method of Nothing -> "toVoidResult" Just t -> case t of JBoolean -> "toBooleanResult" JChar -> "toCharResult" JByte -> "toByteResult" JShort -> "toShortResult" JInt -> "toIntResult" JLong -> "toLongResult" JFloat -> "toFloatResult" JDouble -> "toDoubleResult" JObj n -> "toObjectResult" JArr c -> "toArrayResult" mkMethodNames :: [JavaMethod] -> [String] mkMethodNames = concatMap (zipWith (flip (++)) (iterate (++"'") "")) . List.group . map sanitize . map methodName where sanitize name | Char.isUpper (head name) = '_' : name | name `elem` haskellKeywords = name ++ "'" | otherwise = name -- Hidden Modules and Boot files classModExports' :: Map String JavaClass -> JavaClass -> String classModExports' info clazz = """ #{tyclTName haskName}, #{dataTName haskName} (..), #{newtTName haskName} #{if classEnum clazz then "(..)" else ""}, """ where haskName = takeClassName $ classModName clazz javaName = className clazz classBootExports' :: Map String JavaClass -> JavaClass -> String classBootExports' info clazz = """ #{tyclTName haskName}, #{dataTName haskName} (..), #{newtTName haskName}, """ where haskName = takeClassName $ classModName clazz javaName = className clazz classBootImports' :: Map String JavaClass -> JavaClass -> String classBootImports' info clazz = concatMap (format . classModName) supertypes where format modName = """import qualified #{modName}__\n""" supertypes = map (check . flip Map.lookup info) $ Set.toList $ Set.fromList (classParents clazz ++ classIfaces clazz) check = maybe (error """ classBootImports' in Foreign.Java.Bindings.Java2Haskell \ - class definition not found""") id classModImports' :: Map String JavaClass -> JavaClass -> String classModImports' info clazz = "" classBootDecl' :: Map String JavaClass -> JavaClass -> String classBootDecl' info clazz | classEnum clazz = """ class #{tyclTDecl} data #{newtTDecl} = #{enumConstants} data #{dataTDecl} = #{dataCDecl} """ | otherwise = """ class #{tyclTDecl} newtype #{newtTDecl} = #{newtCDecl} JNI.JObject data #{dataTDecl} = #{dataCDecl} """ where baseName = takeClassName $ classModName clazz params = concatMap (\(p:ps) -> ' ' : Char.toLower p : ps) $ map (tyVarName . paramName) $ classTypeParams clazz newtTDecl = newtTName baseName ++ params newtCDecl = newtCName baseName dataTDecl = dataTName baseName ++ params dataCDecl = dataCName baseName ++ params tyclTDecl = """(JNI.JavaObject this#{context}) => #{tyclTName baseName} this""" context = concatMap parentContext (classParents clazz) parentContext parent = """, #{qualifiedName} this""" where parentClass = info Map.! parent modName = classModName parentClass qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName) enumConstants = concat $ List.intersperse " | " $ map sanitize $ map snd $ classEnumConstants clazz where sanitize (x:xs) = Char.toUpper x : xs classModDecl' :: Map String JavaClass -> JavaClass -> String classModDecl' info clazz | classEnum clazz = """ instance JNI.JavaObject (#{newtTDecl}) where asObject = Prelude.undefined instance #{tyclTName baseName} (#{newtTDecl}) instance JNIS.InstanceOf (#{dataTDecl}) where type CoercedType (#{dataTDecl}) = (#{newtTDecl}) #{instances} """ | otherwise = """ instance JNI.JavaObject (#{newtTDecl}) where asObject (#{newtCName baseName} obj) = return obj 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 (Prelude.Just clazz) <- JNI.getClass "#{fullClassName}" isInstanceOf <- obj `JNI.isInstanceOf` clazz if isInstanceOf then Prelude.Just <$> (JNIS.unsafeFromJObject obj) else return Prelude.Nothing #{instances} """ where fullClassName = classFullName clazz baseName = takeClassName $ classModName clazz params = concatMap (\(p:ps) -> ' ' : Char.toLower p : ps) $ map (tyVarName . paramName) $ classTypeParams clazz newtTDecl = newtTName baseName ++ params newtCDecl = newtCName baseName dataTDecl = dataTName baseName ++ params dataCDecl = dataCName baseName ++ params instances = concatMap parentInstance (classParents clazz) parentInstance parent = """ instance #{qualifiedName} (#{newtTDecl}) """ where parentClass = info Map.! parent modName = classModName parentClass qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName)