{-# LANGUAGE Haskell2010 #-} module Translate where import Typomatic import Foreign.Java.Utils import Data.Map (Map) import Language.Haskell.Reflect import Language.Java.Reflect 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) -> ((\_ -> let { __ = {-# LINE 25 "Translate.hss" #-} concat [" -- * ", (show t), "s\n", (b), ""] {-# LINE 25 "Translate.hss" #-} } in __) undefined)) $ 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 ((\_ -> let { __ = {-# LINE 34 "Translate.hss" #-} concat [" ", (dataTName haskName), " (..),\n"] {-# LINE 34 "Translate.hss" #-} } in __) undefined) in ((\_ -> let { __ = {-# LINE 35 "Translate.hss" #-} concat [" -- ** ", (show $ classType clazz), " ", (javaName), "\n -- | For constructors, methods, and so on, see: \"", (classModName clazz), "\".\n ", (tyclTName haskName), ",\n", (dataDecl), " ", (newtTName haskName), " ", (if classEnum clazz then "(..)" else ""), ",\n"] {-# LINE 41 "Translate.hss" #-} } in __) undefined) pkgModImports :: Map String JavaClass -> [JavaClass] -> String pkgModImports info classes = concatMap (format . classModName) classes where format modName = ((\_ -> let { __ = {-# LINE 46 "Translate.hss" #-} concat ["import ", (modName), "__ hiding (info')\n"] {-# LINE 46 "Translate.hss" #-} } in __) undefined) 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 = ((\_ -> let { __ = {-# LINE 66 "Translate.hss" #-} concat ["import qualified ", (package), "\n"] {-# LINE 66 "Translate.hss" #-} } in __) undefined) references = Set.toList $ Set.map (fst . splitClassName . classModName . check . flip Map.lookup info) $ Set.fromList (classFullName clazz : dependencies) dependencies = classDependencies clazz check = maybe (error ((\_ -> let { __ = {-# LINE 71 "Translate.hss" #-} concat ["classModImports in Foreign.Java.Bindings.Java2Haskell - class definition not found"] {-# LINE 73 "Translate.hss" #-} } in __) undefined)) id classBootDecl :: Map String JavaClass -> JavaClass -> String classBootDecl info clazz = ((\_ -> let { __ = {-# LINE 77 "Translate.hss" #-} concat [""] {-# LINE 78 "Translate.hss" #-} } in __) undefined) 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 = ((\_ -> let { __ = {-# LINE 94 "Translate.hss" #-} concat ["", (name), " :: ", (signature), "\n", (name), " = Prelude.undefined\n"] {-# LINE 97 "Translate.hss" #-} } in __) undefined) | otherwise = ((\_ -> let { __ = {-# LINE 98 "Translate.hss" #-} concat ["", (haddock), "\n", (name), " :: ", (signature), "\n", (name), "", (argsDecl), " = do\n (Prelude.Just clazz) <- JNI.getClass \"", (classFullName clazz), "\"\n (Prelude.Just method) <- clazz `JNI.", (getMethod), "` ", (jniSignature), "\n", (thisArg), "", (readArgs), " result <- JNI.", (callMethod), " method ", (argsRefs), "\n ", (convertResult), " result\n"] {-# LINE 108 "Translate.hss" #-} } in __) undefined) where arrayTypes -- | any isArrayType (methodParams method) = True | (Just ret) <- fst (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 = ((\_ -> let { __ = {-# LINE 127 "Translate.hss" #-} concat ["-- | @", (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), "@"] {-# LINE 132 "Translate.hss" #-} } in __) undefined) thisArg = if isStatic then "" else ((\_ -> let { __ = {-# LINE 133 "Translate.hss" #-} concat [" ", (head args), "' <- JNI.asObject ", (head args), "\n"] {-# LINE 133 "Translate.hss" #-} } in __) undefined) readArgs = concatMap ((" " ++). uncurry readArg) (zip argsNotThis (map fst $ methodParams method)) readArg name jtype = case jtype of JBoolean -> ((\_ -> let { __ = {-# LINE 136 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toBoolean ", (name), "\n"] {-# LINE 136 "Translate.hss" #-} } in __) undefined) JChar -> ((\_ -> let { __ = {-# LINE 137 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toChar ", (name), "\n"] {-# LINE 137 "Translate.hss" #-} } in __) undefined) JByte -> ((\_ -> let { __ = {-# LINE 138 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toByte ", (name), "\n"] {-# LINE 138 "Translate.hss" #-} } in __) undefined) JShort -> ((\_ -> let { __ = {-# LINE 139 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toShort ", (name), "\n"] {-# LINE 139 "Translate.hss" #-} } in __) undefined) JInt -> ((\_ -> let { __ = {-# LINE 140 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toInt ", (name), "\n"] {-# LINE 140 "Translate.hss" #-} } in __) undefined) JLong -> ((\_ -> let { __ = {-# LINE 141 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toLong ", (name), "\n"] {-# LINE 141 "Translate.hss" #-} } in __) undefined) JFloat -> ((\_ -> let { __ = {-# LINE 142 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toFloat ", (name), "\n"] {-# LINE 142 "Translate.hss" #-} } in __) undefined) JDouble -> ((\_ -> let { __ = {-# LINE 143 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toDouble ", (name), "\n"] {-# LINE 143 "Translate.hss" #-} } in __) undefined) JObj _ -> ((\_ -> let { __ = {-# LINE 144 "Translate.hss" #-} concat ["", (name), "' <- Prelude.Just <$> JNI.asObject ", (name), "\n"] {-# LINE 144 "Translate.hss" #-} } in __) undefined) JArr _ -> ((\_ -> let { __ = {-# LINE 145 "Translate.hss" #-} concat ["", (name), "' <- JNIS.asMaybeArrayObject ", (name), "\n"] {-# LINE 145 "Translate.hss" #-} } in __) undefined) convertResult = ("JNIS." ++) $ case fst (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 = ((\_ -> let { __ = {-# LINE 176 "Translate.hss" #-} concat [" ", (tyclTName haskName), ",\n ", (dataTName haskName), " (..),\n ", (newtTName haskName), " ", (if classEnum clazz then "(..)" else ""), ",\n"] {-# LINE 180 "Translate.hss" #-} } in __) undefined) where haskName = takeClassName $ classModName clazz javaName = className clazz classBootExports' :: Map String JavaClass -> JavaClass -> String classBootExports' info clazz = ((\_ -> let { __ = {-# LINE 187 "Translate.hss" #-} concat [" ", (tyclTName haskName), ",\n ", (dataTName haskName), " (..),\n ", (newtTName haskName), ",\n"] {-# LINE 191 "Translate.hss" #-} } in __) undefined) where haskName = takeClassName $ classModName clazz javaName = className clazz classBootImports' :: Map String JavaClass -> JavaClass -> String classBootImports' info clazz = concatMap (format . classModName) supertypes where format modName = ((\_ -> let { __ = {-# LINE 201 "Translate.hss" #-} concat ["import qualified ", (modName), "__\n"] {-# LINE 201 "Translate.hss" #-} } in __) undefined) supertypes = map (check . flip Map.lookup info) $ Set.toList $ Set.fromList (classParents clazz ++ classIfaces clazz) check = maybe (error ((\_ -> let { __ = {-# LINE 205 "Translate.hss" #-} concat ["classBootImports' in Foreign.Java.Bindings.Java2Haskell - class definition not found"] {-# LINE 207 "Translate.hss" #-} } in __) undefined)) id classModImports' :: Map String JavaClass -> JavaClass -> String classModImports' info clazz = "" classBootDecl' :: Map String JavaClass -> JavaClass -> String classBootDecl' info clazz | classEnum clazz = ((\_ -> let { __ = {-# LINE 216 "Translate.hss" #-} concat ["class ", (tyclTDecl), "\ndata ", (newtTDecl), " = ", (enumConstants), "\ndata ", (dataTDecl), " = ", (dataCDecl), "\n"] {-# LINE 220 "Translate.hss" #-} } in __) undefined) | otherwise = ((\_ -> let { __ = {-# LINE 221 "Translate.hss" #-} concat ["class ", (tyclTDecl), "\nnewtype ", (newtTDecl), " = ", (newtCDecl), " JNI.JObject\ndata ", (dataTDecl), " = ", (dataCDecl), "\n"] {-# LINE 225 "Translate.hss" #-} } in __) undefined) 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 = ((\_ -> let { __ = {-# LINE 233 "Translate.hss" #-} concat ["(JNI.JavaObject this", (context), ") => ", (tyclTName baseName), " this"] {-# LINE 233 "Translate.hss" #-} } in __) undefined) context = concatMap parentContext (classParents clazz) parentContext parent = ((\_ -> let { __ = {-# LINE 235 "Translate.hss" #-} concat [", ", (qualifiedName), " this"] {-# LINE 235 "Translate.hss" #-} } in __) undefined) 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 = ((\_ -> let { __ = {-# LINE 245 "Translate.hss" #-} concat ["instance JNI.JavaObject (", (newtTDecl), ") where\n asObject = Prelude.undefined\ninstance ", (tyclTName baseName), " (", (newtTDecl), ")\ninstance JNIS.InstanceOf (", (dataTDecl), ") where\n type CoercedType (", (dataTDecl), ") = (", (newtTDecl), ")\n", (instances), "\n"] {-# LINE 252 "Translate.hss" #-} } in __) undefined) | otherwise = ((\_ -> let { __ = {-# LINE 253 "Translate.hss" #-} concat ["instance JNI.JavaObject (", (newtTDecl), ") where\n asObject (", (newtCName baseName), " obj) = return obj\ninstance JNIS.UnsafeCast (", (newtTDecl), ") where\n unsafeFromJObject obj = return (", (newtCDecl), " obj)\ninstance ", (tyclTName baseName), " (", (newtTDecl), ")\ninstance JNIS.InstanceOf (", (dataTDecl), ") where\n type CoercedType (", (dataTDecl), ") = (", (newtTDecl), ")\n coerce o t = do\n obj <- JNI.asObject o\n (Prelude.Just clazz) <- JNI.getClass \"", (fullClassName), "\"\n isInstanceOf <- obj `JNI.isInstanceOf` clazz\n if isInstanceOf\n then Prelude.Just <$> (JNIS.unsafeFromJObject obj)\n else return Prelude.Nothing\n", (instances), "\n"] {-# LINE 269 "Translate.hss" #-} } in __) undefined) 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 = ((\_ -> let { __ = {-# LINE 279 "Translate.hss" #-} concat ["instance ", (qualifiedName), " (", (newtTDecl), ")\n"] {-# LINE 281 "Translate.hss" #-} } in __) undefined) where parentClass = info Map.! parent modName = classModName parentClass qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName)