{-# LANGUAGE Haskell2010 #-} {-# OPTIONS -Wall #-} module Translate where import Typomatic import Utils import Foreign.Java.Utils import Data.Map (Map) import Language.Haskell.Reflect import Language.Java.Reflect import qualified Language.Java.Reflect.Types as Types 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 Haskell.X as X import Control.Arrow checkedLookup info name = maybe fail id (Map.lookup name info) where fail = error ((\_ -> let { __ = {-# LINE 29 "Translate.hss" #-} concat ["class definition for '", (name), "' not found."] {-# LINE 29 "Translate.hss" #-} } in __) undefined) pkgModExports :: ClassInfo -> [JavaClass] -> String pkgModExports info classes = concatMap (\(t, b) -> ((\_ -> let { __ = {-# LINE 34 "Translate.hss" #-} concat [" -- * ", (show t), "s\n", (b), ""] {-# LINE 34 "Translate.hss" #-} } in __) undefined)) $ map (second $ concatMap format) $ X.aggregateAL $ zip (map classType classes) classes where format clazz = let modName = (classModName info . className) clazz haskName = takeClassName $ modName javaName = takeClassName $ className clazz dataDecl = if classIface clazz then "" else ((\_ -> let { __ = {-# LINE 44 "Translate.hss" #-} concat [" ", (dataTName haskName), " (..),\n"] {-# LINE 44 "Translate.hss" #-} } in __) undefined) in ((\_ -> let { __ = {-# LINE 45 "Translate.hss" #-} concat [" -- ** ", (show $ classType clazz), " ", (javaName), "\n -- | For constructors, methods, and so on, see: \"", (modName), "\".\n ", (tyclTName haskName), ",\n", (dataDecl), " ", (newtTName haskName), " ", (if classEnum clazz then "(..)" else ""), ",\n"] {-# LINE 51 "Translate.hss" #-} } in __) undefined) pkgModImports :: ClassInfo -> [JavaClass] -> String pkgModImports info classes = concatMap (format . getModName) classes where format modName = ((\_ -> let { __ = {-# LINE 57 "Translate.hss" #-} concat ["import ", (modName), "__ hiding (info')\n"] {-# LINE 57 "Translate.hss" #-} } in __) undefined) getModName = (classModName info . className) pkgModDecl :: ClassInfo -> [JavaClass] -> String pkgModDecl info classes = "" classModImports :: ClassInfo -> JavaClass -> String classModImports info clazz = concatMap format references where format package = ((\_ -> let { __ = {-# LINE 68 "Translate.hss" #-} concat ["import qualified ", (package), "\n"] {-# LINE 68 "Translate.hss" #-} } in __) undefined) references = Set.toList $ Set.map (fst . splitClassName . getModName . checkedLookup info) $ Set.fromList (className clazz : dependencies) dependencies = classDependencies clazz getModName = (classModName info . className) classModExports :: ClassInfo -> 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 :: ClassInfo -> 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 90 "Translate.hss" #-} concat ["", (name), " :: ", (signature), "\n", (name), " = Prelude.undefined\n"] {-# LINE 93 "Translate.hss" #-} } in __) undefined) | otherwise = ((\_ -> let { __ = {-# LINE 94 "Translate.hss" #-} concat ["", (haddock), "\n", (name), " :: ", (signature), "\n", (name), "", (argsDecl), " = do\n (Prelude.Just clazz) <- JNI.getClass \"", (className clazz), "\"\n (Prelude.Just method) <- clazz `JNI.", (getMethod), "` ", (jniSignature), "\n", (thisArg), "", (readArgs), " result <- JNI.", (callMethod), " method ", (argsRefs), "\n ", (convertResult), " result\n"] {-# LINE 104 "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 123 "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 128 "Translate.hss" #-} } in __) undefined) thisArg = if isStatic then "" else ((\_ -> let { __ = {-# LINE 129 "Translate.hss" #-} concat [" ", (head args), "' <- JNI.asObject ", (head args), "\n"] {-# LINE 129 "Translate.hss" #-} } in __) undefined) readArgs = concatMap ((" " ++). uncurry readArg) (zip argsNotThis (map fst $ methodParams method)) readArg name jtype = case jtype of JBoolean -> ((\_ -> let { __ = {-# LINE 132 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toBoolean ", (name), "\n"] {-# LINE 132 "Translate.hss" #-} } in __) undefined) JChar -> ((\_ -> let { __ = {-# LINE 133 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toChar ", (name), "\n"] {-# LINE 133 "Translate.hss" #-} } in __) undefined) JByte -> ((\_ -> let { __ = {-# LINE 134 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toByte ", (name), "\n"] {-# LINE 134 "Translate.hss" #-} } in __) undefined) JShort -> ((\_ -> let { __ = {-# LINE 135 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toShort ", (name), "\n"] {-# LINE 135 "Translate.hss" #-} } in __) undefined) JInt -> ((\_ -> let { __ = {-# LINE 136 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toInt ", (name), "\n"] {-# LINE 136 "Translate.hss" #-} } in __) undefined) JLong -> ((\_ -> let { __ = {-# LINE 137 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toLong ", (name), "\n"] {-# LINE 137 "Translate.hss" #-} } in __) undefined) JFloat -> ((\_ -> let { __ = {-# LINE 138 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toFloat ", (name), "\n"] {-# LINE 138 "Translate.hss" #-} } in __) undefined) JDouble -> ((\_ -> let { __ = {-# LINE 139 "Translate.hss" #-} concat ["", (name), "' <- JNIS.toDouble ", (name), "\n"] {-# LINE 139 "Translate.hss" #-} } in __) undefined) JObj _ -> ((\_ -> let { __ = {-# LINE 140 "Translate.hss" #-} concat ["", (name), "' <- Prelude.Just <$> JNI.asObject ", (name), "\n"] {-# LINE 140 "Translate.hss" #-} } in __) undefined) JArr _ -> ((\_ -> let { __ = {-# LINE 141 "Translate.hss" #-} concat ["", (name), "' <- JNIS.asMaybeArrayObject ", (name), "\n"] {-# LINE 141 "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' :: ClassInfo -> JavaClass -> String classModExports' info clazz = ((\_ -> let { __ = {-# LINE 172 "Translate.hss" #-} concat [" ", (tyclTName haskName), ",\n ", (dataTName haskName), " (..),\n ", (newtTName haskName), " ", (if classEnum clazz then "(..)" else ""), ",\n"] {-# LINE 176 "Translate.hss" #-} } in __) undefined) where haskName = takeClassName $ classModName clazz javaName = takeClassName $ className clazz classBootExports' :: ClassInfo -> JavaClass -> String classBootExports' info clazz = ((\_ -> let { __ = {-# LINE 183 "Translate.hss" #-} concat [" ", (tyclTName haskName), ",\n ", (dataTName haskName), " (..),\n ", (newtTName haskName), ",\n"] {-# LINE 187 "Translate.hss" #-} } in __) undefined) where haskName = takeClassName $ classModName clazz javaName = takeClassName $ className clazz classBootImports' :: ClassInfo -> JavaClass -> String classBootImports' info clazz = concatMap (format . classModName) supertypes where format modName = ((\_ -> let { __ = {-# LINE 197 "Translate.hss" #-} concat ["import qualified ", (modName), "__\n"] {-# LINE 197 "Translate.hss" #-} } in __) undefined) supertypes = map (checkedLookup info) $ Set.toList $ Set.fromList (classParents clazz ++ classIfaces clazz) classModImports' :: ClassInfo -> JavaClass -> String classModImports' info clazz = "" classBootDecl' :: ClassInfo -> JavaClass -> String classBootDecl' info clazz | classEnum clazz = ((\_ -> let { __ = {-# LINE 209 "Translate.hss" #-} concat ["class ", (tyclTDecl), "\ndata ", (newtTDecl), " = ", (enumConstants), "\ndata ", (dataTDecl), " = ", (dataCDecl), "\n"] {-# LINE 213 "Translate.hss" #-} } in __) undefined) | otherwise = ((\_ -> let { __ = {-# LINE 214 "Translate.hss" #-} concat ["class ", (tyclTDecl), "\nnewtype ", (newtTDecl), " = ", (newtCDecl), " JNI.JObject\ndata ", (dataTDecl), " = ", (dataCDecl), "\n"] {-# LINE 218 "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 226 "Translate.hss" #-} concat ["(JNI.JavaObject this", (context), ") => ", (tyclTName baseName), " this"] {-# LINE 226 "Translate.hss" #-} } in __) undefined) context = concatMap parentContext (classParents clazz) parentContext parent = ((\_ -> let { __ = {-# LINE 228 "Translate.hss" #-} concat [", ", (qualifiedName), " this"] {-# LINE 228 "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' :: ClassInfo -> JavaClass -> String classModDecl' info clazz | classEnum clazz = ((\_ -> let { __ = {-# LINE 238 "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 245 "Translate.hss" #-} } in __) undefined) | otherwise = ((\_ -> let { __ = {-# LINE 246 "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 262 "Translate.hss" #-} } in __) undefined) where fullClassName = className 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 272 "Translate.hss" #-} concat ["instance ", (qualifiedName), " (", (newtTDecl), ")\n"] {-# LINE 274 "Translate.hss" #-} } in __) undefined) where parentClass = info Map.! parent modName = classModName parentClass qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName)