{-# 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 """class definition for '#{name}' not found.""" pkgModExports :: ClassInfo -> [JavaClass] -> String pkgModExports info classes = concatMap (\(t, b) -> """ -- * #{show t}s\n#{b}""") $ 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 """ #{dataTName haskName} (..),\n""" in """ -- ** #{show $ classType clazz} #{javaName} -- | For constructors, methods, and so on, see: "#{modName}". #{tyclTName haskName}, #{dataDecl}\ #{newtTName haskName} #{if classEnum clazz then "(..)" else ""}, """ pkgModImports :: ClassInfo -> [JavaClass] -> String pkgModImports info classes = concatMap (format . getModName) classes where format modName = """import #{modName}__ hiding (info')\n""" getModName = (classModName info . className) pkgModDecl :: ClassInfo -> [JavaClass] -> String pkgModDecl info classes = "" classModImports :: ClassInfo -> JavaClass -> String classModImports info clazz = concatMap format references where format package = """import qualified #{package}\n""" 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 = """ #{name} :: #{signature} #{name} = Prelude.undefined """ | otherwise = """ #{haddock} #{name} :: #{signature} #{name}#{argsDecl} = do (Prelude.Just clazz) <- JNI.getClass "#{className 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) <- 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 = """ -- | @#{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 (map fst $ 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 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 = """ #{tyclTName haskName}, #{dataTName haskName} (..), #{newtTName haskName} #{if classEnum clazz then "(..)" else ""}, """ where haskName = takeClassName $ classModName clazz javaName = takeClassName $ className clazz classBootExports' :: ClassInfo -> JavaClass -> String classBootExports' info clazz = """ #{tyclTName haskName}, #{dataTName haskName} (..), #{newtTName haskName}, """ where haskName = takeClassName $ classModName clazz javaName = takeClassName $ className clazz classBootImports' :: ClassInfo -> JavaClass -> String classBootImports' info clazz = concatMap (format . classModName) supertypes where format modName = """import qualified #{modName}__\n""" 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 = """ 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' :: ClassInfo -> 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 = 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 = """ instance #{qualifiedName} (#{newtTDecl}) """ where parentClass = info Map.! parent modName = classModName parentClass qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName)