j2hs 0.9.1 → 0.99
raw patch · 19 files changed
+2287/−1705 lines, 19 filesdep +hxdep +strictdep −haskell-reflectdep −hinduce-missinghdep −multimapdep ~java-bridgedep ~java-bridge-extrasdep ~java-reflect
Dependencies added: hx, strict
Dependencies removed: haskell-reflect, hinduce-missingh, multimap
Dependency ranges changed: java-bridge, java-bridge-extras, java-reflect
Files
- dist/build/j2hs/j2hs-tmp/Bindings.hs +0/−119
- dist/build/j2hs/j2hs-tmp/CodeGen/JavaBindings.hs +478/−0
- dist/build/j2hs/j2hs-tmp/Java2Haskell.hs +199/−179
- dist/build/j2hs/j2hs-tmp/Main.hs +13/−8
- dist/build/j2hs/j2hs-tmp/Segments.hs +159/−0
- dist/build/j2hs/j2hs-tmp/Translate.hs +0/−344
- j2hs.cabal +11/−11
- src/Bindings.hss +0/−163
- src/CodeGen/Class.hs +74/−0
- src/CodeGen/JavaBindings.hss +503/−0
- src/CodeGen/Typomatic.hs +481/−0
- src/Java2Haskell.hss +174/−159
- src/Main.hss +9/−4
- src/Options.hs +4/−2
- src/Segments.hss +144/−0
- src/Translate.hss +0/−286
- src/Types.hs +23/−0
- src/Typomatic.hs +0/−411
- src/Utils.hs +15/−19
− dist/build/j2hs/j2hs-tmp/Bindings.hs
@@ -1,119 +0,0 @@-{-# LANGUAGE Haskell2010 #-}-{-# OPTIONS -Wall #-}---- | Functions for generating glue code between Haskell and Java.-module Bindings (-- -- * Create Haskell glue code from Java definitions- printJavaPackageModule,- printJavaClassModule,- printJavaClassBootfile,- printJavaClassModule',- printJavaClassBootfile',-- ) where--import Translate-import Foreign.Java.Utils-import Language.Java.Reflect.Types--import Data.Map (Map)--imports :: String--- ^ Imports of all auto generated java code files.-imports = ((\_ -> let { __ = -{-# LINE 24 "Bindings.hss" #-}-concat ["import qualified Foreign.Java as JNI\nimport Foreign.Java ((-->))\nimport qualified Prelude as Prelude\nimport Prelude ((.), ($), (>>=), (>>), return)\nimport qualified Foreign.Java.Bindings as JNIS\nimport Data.Functor ((<$>))\n"]-{-# LINE 31 "Bindings.hss" #-}-} in __) undefined)--classInfoSignature :: String--- ^ -classInfoSignature = "Prelude.String"--classInfo' :: JavaClass -> String--- ^ -classInfo' clazz = className clazz--packageInfo' :: String -> a -> String-packageInfo' packageName classes = packageName--printJavaPackageModule :: String -- The Java package name- -> String -- The Haskell module name of the Java package- -> Map String JavaClass -- Info about all other classes- -> [JavaClass] -- The Java classes contained in the Java package- -> String--- ^ -printJavaPackageModule packageName modName classInfo classes = ((\_ -> let { __ = -{-# LINE 50 "Bindings.hss" #-}-concat ["{-# LANGUAGE Haskell2010 #-}\n-- | Package @", (packageName), "@\nmodule ", (modName), " (\n", (moduleExports), " info'\n) where\n", (imports), "\n", (moduleImports), "\n-- Information about this package.\ninfo' = ", (show $ packageInfo' packageName classes), "\n", (moduleDeclarations), "\n"]-{-# LINE 62 "Bindings.hss" #-}-} in __) undefined)- where moduleDeclarations = pkgModDecl classInfo classes- moduleImports = pkgModImports classInfo classes- moduleExports = pkgModExports classInfo classes---printJavaClassModule :: JavaClass -- The Java class- -> String -- The Haskell module name of the Java class- -> Map String JavaClass -- Info about all classes- -> String--- ^ -printJavaClassModule clazz modName classInfo = ((\_ -> let { __ = -{-# LINE 73 "Bindings.hss" #-}-concat ["{-# LANGUAGE Haskell2010 #-}\n-- | ", (show $ classType clazz), " @", (classFullName clazz), "@\nmodule ", (modName), " (\n", (moduleExports), " -- * Information about this class.\n info'\n) where\n", (imports), "\n", (bootfileImports), "\n", (moduleImports), "\ninfo' = ", (show $ classInfo' clazz), "\n", (bootfileDeclarations), "\n", (moduleDeclarations), "\n"]-{-# LINE 87 "Bindings.hss" #-}-} in __) undefined)- where bootfileDeclarations = classBootDecl classInfo clazz- bootfileImports = classBootImports classInfo clazz- moduleDeclarations = classModDecl classInfo clazz- moduleImports = classModImports classInfo clazz- moduleExports = classModExports classInfo clazz---printJavaClassBootfile :: JavaClass -- The Java class- -> String -- The Haskell module name of the Java class- -> Map String JavaClass -- Info about all classes- -> String--- ^ -printJavaClassBootfile clazz modName classInfo = ((\_ -> let { __ = -{-# LINE 100 "Bindings.hss" #-}-concat ["{-# LANGUAGE Haskell2010 #-}\n-- Bootfile for class ", (className clazz), "\nmodule ", (modName), " (\n", (bootfileExports), " info'\n) where\n", (imports), "\n", (bootfileImports), "\ninfo' :: ", (classInfoSignature), "\n", (bootfileDeclarations), "\n"]-{-# LINE 111 "Bindings.hss" #-}-} in __) undefined)- where bootfileDeclarations = classBootDecl classInfo clazz- bootfileImports = classBootImports classInfo clazz- bootfileExports = classBootExports classInfo clazz---printJavaClassModule' :: JavaClass -- The Java class- -> String -- The Haskell module name of the Java class- -> Map String JavaClass -- Info about all classes- -> String--- ^ -printJavaClassModule' clazz modName classInfo = ((\_ -> let { __ = -{-# LINE 122 "Bindings.hss" #-}-concat ["{-# LANGUAGE Haskell2010, TypeFamilies #-}\n-- hidden @", (className clazz), "@\nmodule ", (modName), "__ (\n", (moduleExports), " info'\n) where\n", (imports), "\n", (bootfileImports), "\n", (moduleImports), "\ninfo' = ", (show $ classInfo' clazz), "\n", (bootfileDeclarations), "\n", (moduleDeclarations), "\n"]-{-# LINE 135 "Bindings.hss" #-}-} in __) undefined)- where bootfileDeclarations = classBootDecl' classInfo clazz- bootfileImports = classBootImports' classInfo clazz- moduleDeclarations = classModDecl' classInfo clazz- moduleImports = classModImports' classInfo clazz- moduleExports = classModExports' classInfo clazz---printJavaClassBootfile' :: JavaClass -- The Java class- -> String -- The Haskell module name of the Java class- -> Map String JavaClass -- Info about all classes- -> String--- ^ -printJavaClassBootfile' clazz modName classInfo = ((\_ -> let { __ = -{-# LINE 148 "Bindings.hss" #-}-concat ["{-# LANGUAGE Haskell2010 #-}\n-- hidden Bootfile for class ", (className clazz), "\nmodule ", (modName), "__ (\n", (bootfileExports), " info'\n) where\n", (imports), "\n", (bootfileImports), "\ninfo' :: ", (classInfoSignature), "\n", (bootfileDeclarations), "\n"]-{-# LINE 159 "Bindings.hss" #-}-} in __) undefined)- where bootfileDeclarations = classBootDecl' classInfo clazz- bootfileImports = classBootImports' classInfo clazz- bootfileExports = classBootExports' classInfo clazz-
+ dist/build/j2hs/j2hs-tmp/CodeGen/JavaBindings.hs view
@@ -0,0 +1,478 @@+{-# 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 ((\_ -> let { __ = +{-# LINE 28 "CodeGen/JavaBindings.hss" #-}+concat ["import qualified Foreign.Java as JNI\nimport Foreign.Java ((-->))\nimport qualified Prelude as P\nimport Prelude ((.), ($), (>>=), (>>), return)\nimport qualified Foreign.Java.Bindings as JNIS\nimport Data.Functor ((<$>))\n"]+{-# LINE 35 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+++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 ((\_ -> let { __ = +{-# LINE 46 "CodeGen/JavaBindings.hss" #-}+concat ["The @", (packageName), "@ package."]+{-# LINE 46 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ moduleImports <- return deps+ >>= return . concatMap (\name -> "import " ++ name ++ "__\n")+ moduleExports <- return deps+ >>= return . concat . L.intersperse ",\n" . map (\x -> "module " ++ x ++ "__")++ return ((\_ -> let { __ = +{-# LINE 52 "CodeGen/JavaBindings.hss" #-}+concat ["{-# LANGUAGE Haskell2010 #-}\n-- | ", (moduleComment), "\nmodule ", (moduleName), " (\n", (moduleExports), ") where\n", (commonImports), "\n", (moduleImports), "\n"]+{-# LINE 60 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+++readArg :: String -> JavaType -> String+readArg name jtype = case jtype of+ JBoolean -> ((\_ -> let { __ = +{-# LINE 65 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), "' <- JNIS.toBoolean ", (name), "\n"]+{-# LINE 65 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ JChar -> ((\_ -> let { __ = +{-# LINE 66 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), "' <- JNIS.toChar ", (name), "\n"]+{-# LINE 66 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ JByte -> ((\_ -> let { __ = +{-# LINE 67 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), "' <- JNIS.toByte ", (name), "\n"]+{-# LINE 67 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ JShort -> ((\_ -> let { __ = +{-# LINE 68 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), "' <- JNIS.toShort ", (name), "\n"]+{-# LINE 68 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ JInt -> ((\_ -> let { __ = +{-# LINE 69 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), "' <- JNIS.toInt ", (name), "\n"]+{-# LINE 69 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ JLong -> ((\_ -> let { __ = +{-# LINE 70 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), "' <- JNIS.toLong ", (name), "\n"]+{-# LINE 70 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ JFloat -> ((\_ -> let { __ = +{-# LINE 71 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), "' <- JNIS.toFloat ", (name), "\n"]+{-# LINE 71 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ JDouble -> ((\_ -> let { __ = +{-# LINE 72 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), "' <- JNIS.toDouble ", (name), "\n"]+{-# LINE 72 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ JObj _ -> ((\_ -> let { __ = +{-# LINE 73 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), "' <- P.Just <$> JNI.asObject ", (name), "\n"]+{-# LINE 73 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ JArr _ -> ((\_ -> let { __ = +{-# LINE 74 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), "' <- JNIS.asMaybeArrayObject ", (name), "\n"]+{-# LINE 74 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++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 = ((\_ -> let { __ = +{-# LINE 140 "CodeGen/JavaBindings.hss" #-}+concat ["new'", (baseName), ""]+{-# LINE 140 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ constructors+ | classIface clazz = ((\_ -> let { __ = +{-# LINE 142 "CodeGen/JavaBindings.hss" #-}+concat ["-- * Constructors\n", (ifaceConstructor), ",\n\n"]+{-# LINE 145 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ | otherwise = ((\_ -> let { __ = +{-# LINE 146 "CodeGen/JavaBindings.hss" #-}+concat ["-- * Constructors\n", (if null constrs then '-':"- | No Constructors!" else concatMap (++ ",\n") constrNames), "\n\n"]+{-# LINE 149 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ moduleComment <- return ""+ moduleExports <- return ((\_ -> let { __ = +{-# LINE 152 "CodeGen/JavaBindings.hss" #-}+concat ["", (constructors), "\n-- * Fields\n", (if null fields then '-':"- | No Fields!" else concatMap (++ ",\n") fieldNames), "\n\n-- * Methods\n", (if null methods then '-':"- | No Methods!" else concat $ L.intersperse ",\n" methodNames), "\n"]+{-# LINE 159 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ infoFunc <- getClassInfoFunc+ modFunc <- getClassModFunc++ constrDeclarations <- case classIface clazz of+ True -> return ((\_ -> let { __ = +{-# LINE 165 "CodeGen/JavaBindings.hss" #-}+concat ["", (ifaceConstructor), " :: a\n", (ifaceConstructor), " = P.undefined\n\n"]+{-# LINE 168 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ 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 = ((\_ -> let { __ = +{-# LINE 176 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), " :: ", (fSignature argsInfo), "\n", (name), "", (concatMap (' ':) args), " = do\n (P.Just clazz) <- JNI.getClass \"", (className), "\"\n"]+{-# LINE 180 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ case constructorParams constr of+ [] -> return ((\_ -> let { __ = +{-# LINE 183 "CodeGen/JavaBindings.hss" #-}+concat ["", (preamble), "\n JNI.newObjectE clazz >>= JNIS.toObjectResult\n\n"]+{-# LINE 186 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ _ -> return ((\_ -> let { __ = +{-# LINE 187 "CodeGen/JavaBindings.hss" #-}+concat ["", (preamble), "\n (P.Just constr) <- JNI.getConstructor clazz $ ", (fJniSignature argsInfo), "\n", (readArgs), " result <- JNI.newObjectFromE constr ", (concatMap (++ "' ") args), "\n JNIS.toObjectResult result\n\n"]+{-# LINE 193 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+++ 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 = ((\_ -> let { __ = +{-# LINE 206 "CodeGen/JavaBindings.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 ""), "", (fJavaSignature argsInfo), " -> ", (fJavaReturnType argsInfo), "@"]+{-# LINE 211 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ thisArg = if isStatic then "" else ((\_ -> let { __ = +{-# LINE 213 "CodeGen/JavaBindings.hss" #-}+concat [" ", (head args), "' <- JNI.asObject ", (head args), "\n"]+{-# LINE 213 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ readArgs = concatMap ((" " ++) . uncurry readArg)+ (zip argsNotThis (map fst $ methodParams method))++ return ((\_ -> let { __ = +{-# LINE 217 "CodeGen/JavaBindings.hss" #-}+concat ["{- | ", (haddock), " -}\n", (name), " :: ", (fSignature argsInfo), "\n", (name), "", (concatMap (' ':) args), " = do\n (P.Just clazz) <- JNI.getClass \"", (className), "\"\n (P.Just method) <- clazz `JNI.", (getMethod), "` ", (fJniSignature argsInfo), "\n", (thisArg), "", (readArgs), " result <- JNI.", (callMethod), " method ", (concatMap (++ "' ") args), "\n ", (convertResult (fst (methodReturnType method))), " result\n\n"]+{-# LINE 227 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ 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 ((\_ -> let { __ = +{-# LINE 247 "CodeGen/JavaBindings.hss" #-}+concat [" ", (head getterArgs), "' <- JNI.asObject ", (head getterArgs), "\n"]+{-# LINE 247 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ getter = ((\_ -> let { __ = +{-# LINE 249 "CodeGen/JavaBindings.hss" #-}+concat ["", (getterName), " :: ", (fSignature getterInfo), "\n", (getterName), "", (concatMap (' ':) getterArgs), " = do\n (P.Just clazz) <- JNI.getClass \"", (className), "\"\n (P.Just field) <- JNI.", (getField), " clazz \"", (fieldName field), "\" (", (jniType), ")\n", (thisArg), " result <- JNI.", (readField), " field ", (concatMap (++ "' ") getterArgs), "\n ", (convertResult (Just (fst (fieldType field)))), " (P.Right result)\n\n"]+{-# LINE 257 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ setter+ | (Just name) <- setterName = ((\_ -> let { __ = +{-# LINE 259 "CodeGen/JavaBindings.hss" #-}+concat ["", (name), " :: ", (fSignature setterInfo), "\n", (name), "", (concatMap (' ':) setterArgs), " = do\n (P.Just clazz) <- JNI.getClass \"", (className), "\"\n (P.Just field) <- JNI.", (getField), " clazz \"", (fieldName field), "\" (", (jniType), ")\n", (thisArg), " JNI.", (writeField), " field ", (concatMap (++ "' ") setterArgs), "\n return ()\n\n"]+{-# LINE 267 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ | otherwise = ""++ return $ getter ++ setter++ return ((\_ -> let { __ = +{-# LINE 272 "CodeGen/JavaBindings.hss" #-}+concat ["{-# LANGUAGE Haskell2010 #-}\n-- | ", (moduleComment), "\nmodule ", (moduleName), " (\n", (moduleExports), ") where\n", (commonImports), "\n", (moduleImports), "\n", (constrDeclarations), "\n", (methodDeclarations), "\n", (fieldDeclarations), "\n"]+{-# LINE 283 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+++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 ((\_ -> let { __ = +{-# LINE 298 "CodeGen/JavaBindings.hss" #-}+concat ["See \"", (moduleName), "\" for the available methods."]+{-# LINE 298 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ 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 ((\_ -> let { __ = +{-# LINE 311 "CodeGen/JavaBindings.hss" #-}+concat ["instance ", (qualifiedName), " (", (newtTDecl), ")\n"]+{-# LINE 311 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ parentContext parent = do+ modName <- getModNameForClass parent+ let qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName) + return ((\_ -> let { __ = +{-# LINE 316 "CodeGen/JavaBindings.hss" #-}+concat [", ", (qualifiedName), " this"]+{-# LINE 316 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ context <- concat <$> mapM parentContext (classParents clazz)+ instances <- concat <$> mapM parentInstance (classParents clazz)++ let tyclTDecl = ((\_ -> let { __ = +{-# LINE 321 "CodeGen/JavaBindings.hss" #-}+concat ["(JNI.JavaObject this", (context), ") => ", (tyclTName baseName), " this"]+{-# LINE 321 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ enumConstants = map sanitize $ map snd $ classEnumConstants clazz+ where sanitize (x:xs) = C.toUpper x : xs++ newtAdditions+ | classEnum clazz = enumConstants+ | otherwise = []++ newtDeclaration+ | null newtAdditions = ((\_ -> let { __ = +{-# LINE 331 "CodeGen/JavaBindings.hss" #-}+concat ["newtype ", (newtTDecl), " = ", (newtCDecl), " JNI.JObject"]+{-# LINE 331 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ | otherwise = ((\_ -> let { __ = +{-# LINE 332 "CodeGen/JavaBindings.hss" #-}+concat ["data ", (newtTDecl), " = ", (newtCDecl), " JNI.JObject"]+{-# LINE 332 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ ++ concatMap (" | " ++ ) newtAdditions++ newtExport+ | null newtAdditions = ""+ | otherwise = concat (" (" : L.intersperse ", " newtAdditions ++ [")"])++ moduleExports = ((\_ -> let { __ = +{-# LINE 339 "CodeGen/JavaBindings.hss" #-}+concat ["", (tyclTName baseName), ",\n", (dataTName baseName), " (..),\n", (newtTName baseName), "", (newtExport), ",\n"]+{-# LINE 343 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ javaObjectInstance+ | classEnum clazz = ((\_ -> let { __ = +{-# LINE 346 "CodeGen/JavaBindings.hss" #-}+concat ["instance JNI.JavaObject (", (newtTDecl), ") where\n asObject (", (newtCName baseName), " obj) = return obj\n", (concatMap (uncurry asObjectMatch) $ zip enumConstants $ classEnumConstants clazz), ""]+{-# LINE 349 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ | otherwise = ((\_ -> let { __ = +{-# LINE 350 "CodeGen/JavaBindings.hss" #-}+concat ["instance JNI.JavaObject (", (newtTDecl), ") where\n asObject (", (newtCName baseName), " obj) = return obj"]+{-# LINE 352 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ where+ asObjectMatch enum (ord, name) = ((\_ -> let { __ = +{-# LINE 354 "CodeGen/JavaBindings.hss" #-}+concat [" asObject ", (enum), " = do\n -- ", (show ord), ", ", (name), "\n (P.Just clazz) <- JNI.getClass \"", (className), "\"\n (P.Just field) <- JNI.getStaticField clazz \"", (name), "\" (JNI.object \"", (className), "\")\n (P.Just object) <- JNI.readStaticField field\n return object\n"]+{-# LINE 361 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ moduleDeclarations = ((\_ -> let { __ = +{-# LINE 363 "CodeGen/JavaBindings.hss" #-}+concat ["class ", (tyclTDecl), "\n", (newtDeclaration), "\ndata ", (dataTDecl), " = ", (dataCDecl), "\n\n", (javaObjectInstance), "\n\ninstance JNIS.UnsafeCast (", (newtTDecl), ") where\n unsafeFromJObject obj = return (", (newtCDecl), " obj)\n\ninstance ", (tyclTName baseName), " (", (newtTDecl), ")\n\ninstance JNIS.InstanceOf (", (dataTDecl), ") where\n type CoercedType (", (dataTDecl), ") = (", (newtTDecl), ")\n coerce o t = do\n obj <- JNI.asObject o\n (P.Just clazz) <- JNI.getClass \"", (className), "\"\n isInstanceOf <- obj `JNI.isInstanceOf` clazz\n if isInstanceOf\n then P.Just <$> (JNIS.unsafeFromJObject obj)\n else return P.Nothing\n\n", (instances), "\n"]+{-# LINE 386 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++ additionalDeclarations <- case className of+ "java.lang.String" -> return ((\_ -> let { __ = +{-# LINE 389 "CodeGen/JavaBindings.hss" #-}+concat ["instance JNI.JavaObject [P.Char] where\n asObject s = do\n (P.Just clazz) <- JNI.getClass \"java.lang.String\"\n (P.Just valueOf) <- clazz `JNI.getStaticMethod` \"valueOf\" ::= JNI.string --> JNI.object \"java.lang.String\"\n (P.Just string) <- JNI.callStaticMethod valueOf s\n JNI.asObject string\ninstance Java.Lang.Object [P.Char]\ninstance Java.Lang.String [P.Char]\n"]+{-# LINE 398 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ "java.lang.Character" -> return ((\_ -> let { __ = +{-# LINE 399 "CodeGen/JavaBindings.hss" #-}+concat ["instance JNI.JavaObject P.Char where\n asObject ...\ninstance Java.Lang.Object P.Char\ninstance Java.Lang.Character P.Char\n"]+{-# LINE 404 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ "java.lang.Boolean" -> return ((\_ -> let { __ = +{-# LINE 405 "CodeGen/JavaBindings.hss" #-}+concat ["instance JNI.JavaObject P.Bool where\n asObject n = do\n (P.Just clazz) <- JNI.getClass \"java.lang.Boolean\"\n (P.Just valueOf) <- clazz `JNI.getStaticMethod` \"valueOf\"\n ::= JNI.byte --> JNI.object \"java.lang.Boolean\"\n (P.Just boolean) <- JNI.callStaticMethod valueOf n\n JNI.asObject boolean\ninstance Java.Lang.Object P.Bool\ninstance Java.Lang.Boolean P.Bool\n"]+{-# LINE 415 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ "java.lang.Number" -> return ((\_ -> let { __ = +{-# LINE 416 "CodeGen/JavaBindings.hss" #-}+concat [" import qualified Data.Int\n import qualified Data.Word\n instance JNI.JavaObject Data.Int.Int8 where\n asObject n = do\n (P.Just clazz) <- JNI.getClass \"java.lang.Byte\"\n (P.Just valueOf) <- clazz `JNI.getStaticMethod` \"valueOf\"\n ::= JNI.byte --> JNI.object \"java.lang.Byte\"\n (P.Just number) <- JNI.callStaticMethod valueOf n\n JNI.asObject number\n instance JNI.JavaObject Data.Int.Int16 where\n asObject n = do\n (P.Just clazz) <- JNI.getClass \"java.lang.Short\"\n (P.Just valueOf) <- clazz `JNI.getStaticMethod` \"valueOf\"\n ::= JNI.short --> JNI.object \"java.lang.Short\"\n (P.Just number) <- JNI.callStaticMethod valueOf n\n JNI.asObject number\n instance JNI.JavaObject Data.Int.Int32 where\n asObject n = do\n (P.Just clazz) <- JNI.getClass \"java.lang.Integer\"\n (P.Just valueOf) <- clazz `JNI.getStaticMethod` \"valueOf\"\n ::= JNI.int --> JNI.object \"java.lang.Integer\"\n (P.Just number) <- JNI.callStaticMethod valueOf n\n JNI.asObject number\n instance JNI.JavaObject Data.Int.Int64 where\n asObject n = do\n (P.Just clazz) <- JNI.getClass \"java.lang.Long\"\n (P.Just valueOf) <- clazz `JNI.getStaticMethod` \"valueOf\"\n ::= JNI.long --> JNI.object \"java.lang.Long\"\n (P.Just number) <- JNI.callStaticMethod valueOf n\n JNI.asObject number\n\n instance Java.Lang.Object P.Int\n instance Java.Lang.Number P.Int\n instance Java.Lang.Object Data.Int.Int8\n instance Java.Lang.Number Data.Int.Int8\n instance Java.Lang.Object Data.Int.Int16\n instance Java.Lang.Number Data.Int.Int16\n instance Java.Lang.Object Data.Int.Int32\n instance Java.Lang.Number Data.Int.Int32\n instance Java.Lang.Object Data.Int.Int64\n instance Java.Lang.Number Data.Int.Int64\n "]+{-# LINE 458 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ "java.lang.Byte" -> return ((\_ -> let { __ = +{-# LINE 459 "CodeGen/JavaBindings.hss" #-}+concat ["import qualified Data.Int\nimport qualified Data.Word\ninstance Java.Lang.Byte Data.Int\n"]+{-# LINE 463 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ "java.lang.Short" -> return ((\_ -> let { __ = +{-# LINE 464 "CodeGen/JavaBindings.hss" #-}+concat ["import qualified Data.Int\nimport qualified Data.Word\ninstance Java.Lang.Short Data.Int\n"]+{-# LINE 468 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ "java.lang.Integer" -> return ((\_ -> let { __ = +{-# LINE 469 "CodeGen/JavaBindings.hss" #-}+concat ["import qualified Data.Int\nimport qualified Data.Word\ninstance Java.Lang.Integer Data.Int\n"]+{-# LINE 473 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ "java.lang.Long" -> return ((\_ -> let { __ = +{-# LINE 474 "CodeGen/JavaBindings.hss" #-}+concat ["import qualified Data.Int\nimport qualified Data.Word\ninstance Java.Lang.Long Data.Int\n"]+{-# LINE 478 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ "java.lang.Float" -> return ((\_ -> let { __ = +{-# LINE 479 "CodeGen/JavaBindings.hss" #-}+concat ["import qualified Data.Int\nimport qualified Data.Word\ninstance Java.Lang.Float Data.Int\n"]+{-# LINE 483 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+ "java.lang.Double" -> return ((\_ -> let { __ = +{-# LINE 484 "CodeGen/JavaBindings.hss" #-}+concat ["import qualified Data.Int\nimport qualified Data.Word\ninstance Java.Lang.Double Data.Int\n"]+{-# LINE 488 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)+++ return ((\_ -> let { __ = +{-# LINE 491 "CodeGen/JavaBindings.hss" #-}+concat ["{-# LANGUAGE Haskell2010, TypeFamilies, FlexibleInstances #-}\n-- | ", (moduleComment), "\nmodule ", (moduleName), "__ (\n", (moduleExports), "\n) where\n", (commonImports), "\n", (moduleImports), "\n", (additionalDeclarations), "\n", (moduleDeclarations), "\n"]+{-# LINE 501 "CodeGen/JavaBindings.hss" #-}+} in __) undefined)++
dist/build/j2hs/j2hs-tmp/Java2Haskell.hs view
@@ -13,11 +13,13 @@ import Prelude hiding (print) import Options-import Bindings import Utils+import Types+import Segments+import CodeGen.Class+import CodeGen.JavaBindings import Foreign.Java-import Foreign.Java.Utils import Foreign.Java.IO import Language.Java.Reflect@@ -28,22 +30,25 @@ import Data.Generics -import Data.Bimap (Bimap) import Data.Map (Map)-import Data.MultiMap (MultiMap)-import Data.Set (Set)+import MultiMap (MultiMap) import qualified Data.Map as Map import qualified Data.Set as Set-import qualified Data.MultiMap as MultiMap+import qualified MultiMap as MultiMap +import Control.Applicative import Control.Monad import Control.Monad.IO.Class import System.Directory import System.FilePath import System.IO hiding (print)+import qualified System.IO.Strict as Strict import System.Exit +import Haskell.X++ ifVerbose :: MonadIO m => Options@@ -51,65 +56,76 @@ -> m () ifVerbose opts = when (opts `get` optVerbose) . liftIO . putStr +-- | Invoked by Main.main, the core functionality j2hs :: Options -> [String] -> IO () j2hs opts args = do - classpath <- mapM canonicalizePath $ opts `get` optClasspath- targetDir <- return (opts `get` optTargetDirectory)- let reflectDump_ = opts `get` optLoadReflectDump- reflectDump <- if null reflectDump_+ let augmentEnvironment = do+ targetDir <- return (opts `get` optTargetDirectory)+ createDirectoryIfMissing True targetDir++ classpath <- mapM canonicalizePath $ opts `get` optClasspath++ cabalExtra <- if null (opts `get` optCabalPreset)+ then return ""+ else Strict.readFile (opts `get` optCabalPreset)++ setCurrentDirectory targetDir++ return $ opts+ `set` optClasspath := classpath+ `set` optTargetDirectory := targetDir+ `set` optCabalExtra := cabalExtra++ reflectDump <- if null (opts `get` optLoadReflectDump) then return Nothing- else canonicalizePath reflectDump_ >>= return . Just+ else Just <$> canonicalizePath (opts `get` optLoadReflectDump) - let classpath' = concat $ L.intersperse ":" classpath- indent = (" " ++)+ opts <- augmentEnvironment + let classpath = opts `get` optClasspath+ classpath' = concat $ L.intersperse ":" classpath+ ifVerbose opts ((\_ -> let { __ = -{-# LINE 70 "Java2Haskell.hss" #-}+{-# LINE 92 "Java2Haskell.hss" #-} concat ["Classpath:\n", (concatMap (\x -> " " ++ x ++ "\n") (classpath)), ""]-{-# LINE 72 "Java2Haskell.hss" #-}+{-# LINE 94 "Java2Haskell.hss" #-} } in __) undefined) print "Initializing JVM..." initJava [((\_ -> let { __ = -{-# LINE 74 "Java2Haskell.hss" #-}+{-# LINE 96 "Java2Haskell.hss" #-} concat ["-Djava.class.path=", (classpath'), ""]-{-# LINE 74 "Java2Haskell.hss" #-}+{-# LINE 96 "Java2Haskell.hss" #-} } in __) undefined)] println " Done." unless (null args) $ runJava $ do io $ do ifVerbose opts ((\_ -> let { __ = -{-# LINE 79 "Java2Haskell.hss" #-}-concat ["Target Directory:\n ", (targetDir), "\n"]-{-# LINE 82 "Java2Haskell.hss" #-}+{-# LINE 101 "Java2Haskell.hss" #-}+concat ["Target Directory:\n ", (opts `get` optTargetDirectory), "\n"]+{-# LINE 104 "Java2Haskell.hss" #-} } in __) undefined)- createDirectoryIfMissing True targetDir- setCurrentDirectory targetDir ifVerbose opts ((\_ -> let { __ = -{-# LINE 86 "Java2Haskell.hss" #-}+{-# LINE 106 "Java2Haskell.hss" #-} concat ["Looking for Java classes:\n", (concatMap (\x -> " " ++ x ++ "\n") args), ""]-{-# LINE 88 "Java2Haskell.hss" #-}+{-# LINE 108 "Java2Haskell.hss" #-} } in __) undefined) - -- Gather all classes that need to be translated- print "Looking up classes..."- classes <- findClasses (opts `get` optSearchDepth) args+ classInfo <- gatherClassInfo opts reflectDump args - println ((\_ -> let { __ = -{-# LINE 94 "Java2Haskell.hss" #-}-concat [" ", (show $ length classes), " found."]-{-# LINE 94 "Java2Haskell.hss" #-}-} in __) undefined)- ifVerbose opts $- unlines (map indent classes)+ when (opts `get` optOnlyReflect) $ io $ do+ mapM_ println $ Map.elems classInfo+ exitSuccess -- Calculate the Haskell module names for packages and classes- let packages = Set.toList $ Set.fromList+ let classes = Map.keys classInfo++ packages = Set.toList $ Set.fromList $ map (maybe "" id . takePackageName) classes -- temporary class names@@ -128,6 +144,20 @@ || n `xMemberR` all) $ iterate (++ "Package") modName + bimapCheckedLookup bimap name+ = maybe (error ((\_ -> let { __ = +{-# LINE 139 "Java2Haskell.hss" #-}+concat ["Failed lookup in Bimap: ", (show name), "."]+{-# LINE 139 "Java2Haskell.hss" #-}+} in __) undefined)) id $ xLookup bimap name++ mapCheckedLookup map name+ = maybe (error ((\_ -> let { __ = +{-# LINE 142 "Java2Haskell.hss" #-}+concat ["Failed lookup in Map: ", (show name), ""]+{-# LINE 142 "Java2Haskell.hss" #-}+} in __) undefined)) id $ name `Map.lookup` map+ -- finally the class names. -- This func keeps in mind that the package names might have been augmented -- before. i.e. the package java.awt.image will be Java.Awt.ImagePackage now,@@ -138,106 +168,86 @@ = (clazzName, joinClassName (newPackageName, classModuleName)) where classModuleName = takeClassName moduleName packageName = maybe "" id $ takePackageName clazzName- newPackageName = packageModules `xGet` packageName+ newPackageName = bimapCheckedLookup packageModules packageName -- A mapping from packages to classes classesByPackage :: MultiMap String String classesByPackage = MultiMap.fromList $ map (\clazz -> (fst $ splitClassName clazz, clazz)) classes - -- The list of hidden modules- hiddenModules = map (++ "__") $ Map.elems classModules-- classInfo <- gatherClassInfo opts reflectDump classModules-- findJavaCore classesByPackage classInfo-- when (opts `get` optOnlyReflect) $ io $ do- mapM_ println $ Map.elems classInfo- exitSuccess-- generateModules opts classInfo classesByPackage classModules packageModules hiddenModules-- return ()--{--findJavaCore2- :: Map String JavaClass- -> Java ()-findJavaCore2 classInfo = do-- let classes = --}--findJavaCore- :: MultiMap String String- -> Map String JavaClass- -> Java ()-findJavaCore classesByPackage classInfo = do-- let packageDependencies :: Map String (Set String)- packageDependencies = Map.map findDependencies (MultiMap.toMap classesByPackage)- where- findDependencies classes = Set.fromList packageDependencies- where- dependencies = concatMap (classDependencies . (classInfo Map.!)) classes- packageDependencies = map (fst . splitClassName) dependencies+ -- Find a suitable segmentation+ rankedClusters <- findClassClusters classInfo - resolve :: Set String -> Set String- resolve = Set.fromList . concatMap (Set.toList . (packageDependencies Map.!)) . Set.toList+ let segmentSize = min (fromIntegral (opts `get` optSegmentSize)) (Map.size classInfo)+ segments = segment3 segmentSize rankedClusters+ lengths = concat $ L.intersperse ", " $ map (show . length) segments - fullPackageDependencies = Map.map (exhaustively resolve) packageDependencies+ println ((\_ -> let { __ = +{-# LINE 168 "Java2Haskell.hss" #-}+concat ["Identified ", (show $ length segments), " segments of lengths (", (lengths), ")."]+{-# LINE 168 "Java2Haskell.hss" #-}+} in __) undefined) - coreJava = intersections (Map.elems fullPackageDependencies)+ -- Assemble the class info+ let info = ClassInfo {+ aboutClass = mapCheckedLookup classInfo,+ classesForPackage = flip MultiMap.lookup classesByPackage,+ classModName = mapCheckedLookup classModules,+ packageModName = bimapCheckedLookup packageModules,+ allClasses = Map.keys classModules,+ allPackages = xKeys packageModules+ } - println (show $ Set.size coreJava)- println (Set.toList coreJava)+ -- Create the code files.+ let pName = opts `get` optProjectName+ pVersion = opts `get` optProjectVersion+ mkDeps = map (\i -> pName ++ "-part" ++ show i ++ " == " ++ pVersion) - forM_ (Map.toList fullPackageDependencies) $ \(pkg, deps) -> do- let deps' = (deps Set.\\ coreJava)- print ((\_ -> let { __ = -{-# LINE 185 "Java2Haskell.hss" #-}-concat ["", (pkg), ", ", (show $ Set.size deps'), " (", (show $ Set.size deps), ") dependencies:\n "]-{-# LINE 187 "Java2Haskell.hss" #-}-} in __) undefined)- println $ Set.toList deps'+ cwd <- io $ getCurrentDirectory+ forM_ (zip [1 :: Int ..] segments) $ \(i, segment) -> do+ io $ do+ setCurrentDirectory cwd+ createDirectoryIfMissing True (show i)+ setCurrentDirectory (show i)+ let opts' = opts+ `upd` optProjectName := (++ "-part" ++ show i)+ `upd` optDependencies := (++ mkDeps [1..pred i])+ generateClassModules opts' info segment+ io $ setCurrentDirectory cwd + let deps = mkDeps [1..length segments]+ generatePackageModules (opts `upd` optDependencies := (++ deps)) info (allPackages info)+ return () --- Gather information about classes via Reflection--- or (depending on the opts set) from a dump file.+-- | Gather information about classes via Reflection+-- or (depending on the options set) from a dump file. gatherClassInfo :: Options -> Maybe FilePath- -> Map String String+ -> [String] -> Java (Map String JavaClass)-gatherClassInfo opts reflectDump classModules = do+gatherClassInfo opts reflectDump classNames = do + reflectClasses <- getReflectClasses+ print ((\_ -> let { __ = -{-# LINE 200 "Java2Haskell.hss" #-}-concat ["Gathering refection information..."]-{-# LINE 200 "Java2Haskell.hss" #-}+{-# LINE 212 "Java2Haskell.hss" #-}+concat ["Gathering reflection information..."]+{-# LINE 212 "Java2Haskell.hss" #-} } in __) undefined)- let classNames = Map.keys classModules- updName name clazz = (name, clazz { classModName = classModules Map.! name })-- getClassInfo :: Java (Map String JavaClass)- getClassInfo = Map.fromList- `fmap` map (uncurry updName)- `fmap` zip classNames- `fmap` everywhere (mkT (\(TyVar v) -> TyVar ('_':v)))- `fmap` reflectClasses classNames+ let getClassInfo :: Java (Map String JavaClass)+ getClassInfo = everywhere (mkT (\(TyVar v) -> TyVar ('_':v)))+ `fmap` reflectClasses True classNames readClassInfo :: String -> Java (Map String JavaClass)- readClassInfo reflectFile = io $ do- file <- openFile reflectFile ReadMode- contents <- hGetContents file- let contents' = read contents- result <- contents' `seq` return contents'- hClose file- return result+ readClassInfo file = io $ Strict.readFile file >>= return . read classInfo <- maybe getClassInfo (\f -> print " (from dump)" >> readClassInfo f) reflectDump- println " Done."+ println ((\_ -> let { __ = +{-# LINE 221 "Java2Haskell.hss" #-}+concat [" Done (found ", (show $ Map.size classInfo), " classes)."]+{-# LINE 221 "Java2Haskell.hss" #-}+} in __) undefined) unless (null (opts `get` optSaveReflectDump)) $ io $ do file <- openFile (opts `get` optSaveReflectDump) WriteMode@@ -252,101 +262,111 @@ return classInfo ---- This creates a graphviz file which can be used to--- visualize inter-package dependencies-visualizeDependencies- :: Map String (Set String)- -> IO ()-visualizeDependencies packageDependencies = do-- file <- openFile "dependencies.neato" WriteMode- hPutStrLn file ((\_ -> let { __ = -{-# LINE 241 "Java2Haskell.hss" #-}-concat ["digraph G {\n overlap = false;"]-{-# LINE 241 "Java2Haskell.hss" #-}-} in __) undefined)-- forM_ (Map.toList packageDependencies) $ \(pkg, deps) -> do- forM_ (Set.toList deps) $ \dep -> do- let augment = map (\x -> if x == '.' then '_' else x)- pkg' = augment pkg- dep' = augment dep- hPutStr file ((\_ -> let { __ = -{-# LINE 248 "Java2Haskell.hss" #-}-concat [" ", (pkg'), " -> ", (dep'), "\n"]-{-# LINE 248 "Java2Haskell.hss" #-}-} in __) undefined)-- hPutStrLn file ((\_ -> let { __ = -{-# LINE 250 "Java2Haskell.hss" #-}-concat ["}"]-{-# LINE 250 "Java2Haskell.hss" #-}-} in __) undefined)- hClose file---- This actually creates the Haskell module files-generateModules+-- This actually creates the Haskell module files for packages+generatePackageModules :: Options- -> Map String JavaClass- -> MultiMap String String- -> Map String String- -> Bimap CaseInsensitiveString CaseInsensitiveString+ -> ClassInfo -> [String] -> Java ()-generateModules opts classInfo classesByPackage classModules packageModules hiddenModules = do+generatePackageModules opts info packages = do - println ((\_ -> let { __ = -{-# LINE 264 "Java2Haskell.hss" #-}-concat ["Generating modules for ", (show $ Map.size classModules), " classes in ", (show $ xSize packageModules), " packages..."]-{-# LINE 265 "Java2Haskell.hss" #-}+ cwd <- io $ getCurrentDirectory+ print ((\_ -> let { __ = +{-# LINE 241 "Java2Haskell.hss" #-}+concat ["Generating modules for ", (show $ length packages), " packages in ", (cwd), "..."]+{-# LINE 241 "Java2Haskell.hss" #-} } in __) undefined) - -- A list of all modules- let allModules = xKeysR packageModules ++ Map.elems classModules- -- Create all the package files. -- These contain the Java classes as Haskell types.- forM_ (xToList packageModules) $ \(packageName, packageMod) -> do- let dirName = strJoin [pathSeparator] (strSplitAll "." packageMod)+ forM_ packages $ \packageName -> do+ let packageMod = info `packageModName` packageName+ dirName = strJoin [pathSeparator] (strSplitAll "." packageMod) -- Create the directory for the package io $ do createDirectoryIfMissing True dirName - let classes = map (classInfo Map.!)- (MultiMap.lookup packageName classesByPackage)- -- Create the Haskell module file for the Java package file <- openFile (dirName ++ ".hs") WriteMode- hPutStrLn file- $ printJavaPackageModule packageName packageMod classInfo classes+ code <- gen info $ javaPackageModule packageName+ hPutStrLn file code hClose file + when (opts `get` optCabalProject)+ $ writeCabalFile+ (opts `get` optProjectName)+ (opts `get` optProjectVersion)+ (opts `get` optCabalExtra)+ (opts `get` optDependencies)+ (map (info `packageModName`) packages)++ println " Done."+++-- This actually creates the Haskell module files for classes+generateClassModules+ :: Options+ -> ClassInfo+ -> [String]+ -> Java ()+generateClassModules opts info classes = do++ cwd <- io $ getCurrentDirectory+ print ((\_ -> let { __ = +{-# LINE 279 "Java2Haskell.hss" #-}+concat ["Generating modules for ", (show $ length classes), " classes in ", (cwd), "..."]+{-# LINE 279 "Java2Haskell.hss" #-}+} in __) undefined)+ -- Create all the class files. -- These contain the java methods as Haskell functions.- forM_ (Map.toList classModules) $ \(clazzName, clazzMod) -> do- let fileName = strJoin [pathSeparator] (strSplitAll "." clazzMod)- clazz = classInfo Map.! clazzName+ forM_ classes $ \className -> do+ let fileName = strJoin [pathSeparator] (strSplitAll "." (info `classModName` className))+ dirName = takeDirectory fileName io $ do+ createDirectoryIfMissing True dirName+ -- Create the Haskell module file for the Java class. file <- openFile (fileName ++ ".hs") WriteMode- hPutStrLn file $ printJavaClassModule clazz clazzMod classInfo+ code <- gen info $ javaClassModule className+ hPutStrLn file code hClose file - -- Create the *hidden* Haskell module file for the Java class.+ -- Create the interface Haskell module file for the Java class. file <- openFile (fileName ++ "__.hs") WriteMode- hPutStrLn file $ printJavaClassModule' clazz clazzMod classInfo+ code <- gen info $ javaClassModule' className+ hPutStrLn file code hClose file - -- write Cabal file- when (opts `get` optCabalProject) $ io $ do- cabalFile <- openFile ((opts `get` optProjectName) ++ ".cabal") WriteMode- hPutStrLn cabalFile ((\_ -> let { __ = -{-# LINE 308 "Java2Haskell.hss" #-}-concat ["name: ", (opts `get` optProjectName), "\nversion: ", (opts `get` optProjectVersion), "\ncabal-version: >= 1.8\nbuild-type: Simple\n\nLibrary {\n build-depends:\n base >= 4 && < 5,\n java-bridge\n exposed-modules:\n ", (strJoin ",\n " allModules), "\n other-modules:\n ", (strJoin ",\n " hiddenModules), " }\n"]-{-# LINE 322 "Java2Haskell.hss" #-}+ let modules = map (info `classModName`) classes+ when (opts `get` optCabalProject)+ $ writeCabalFile+ (opts `get` optProjectName)+ (opts `get` optProjectVersion)+ (opts `get` optCabalExtra)+ (opts `get` optDependencies)+ (modules ++ map (++ "__") modules)++ println " Done."+++-- | Write a cabal project file. Can be used in any MonadIO, e.g. IO or Java or...+writeCabalFile :: MonadIO m =>+ String -- project name+ -> String -- project version+ -> String -- extra + -> [String] -- dependencies+ -> [String] -- public module list+ -> m ()+writeCabalFile projectName projectVersion extra dependencies modules = liftIO $ do++ cabalFile <- openFile (projectName ++ ".cabal") WriteMode+ hPutStrLn cabalFile ((\_ -> let { __ = +{-# LINE 325 "Java2Haskell.hss" #-}+concat ["name: ", (projectName), "\nversion: ", (projectVersion), "\ncabal-version: >= 1.8\nbuild-type: Simple\n", (extra), "\nLibrary\n build-depends:\n base >= 4 && < 5", (concatMap (",\n " ++) dependencies), "\n exposed-modules:\n ", (strJoin ",\n " modules), "\n"]+{-# LINE 337 "Java2Haskell.hss" #-} } in __) undefined)- hClose cabalFile+ hClose cabalFile
dist/build/j2hs/j2hs-tmp/Main.hs view
@@ -40,10 +40,11 @@ | Version | Packages [String] | Classpath [String]- | SearchDepth Word32+ | SegmentSize Word32 | TargetDirectory String | SaveReflectDump String | LoadReflectDump String+ | CabalPresetFile String | CompleteSE6 | OnlyReflect | Filtered@@ -63,7 +64,10 @@ Option "P" ["packages"] (ReqArg readPackages "") "The packages to translate.", - Option "d" ["search-depth"] (ReqArg readSearchDepth "")+ Option "p" ["cabal-preset"] (ReqArg CabalPresetFile "")+ "A file containing presets for cabal project files. The contents are included literally.",++ Option "s" ["segment-size"] (ReqArg readSegmentSize "") "The maximum search depth for dependent Java classes.", Option "v" ["verbose"] (NoArg Verbose)@@ -87,7 +91,7 @@ ] where readPackages = Packages . splitOneOf ":;," readClasspath = Classpath . splitOneOf ":;,"- readSearchDepth = SearchDepth . read+ readSegmentSize = SegmentSize . read parseArgs :: IO (Either (Options, [String]) [String]) -- ^ Parse command line arguments with the help of the GetOpt library.@@ -108,10 +112,11 @@ OnlyReflect -> opts `set` optOnlyReflect := True Classpath cp -> opts `set` optClasspath := cp Packages pkgs -> opts `set` optPackages := pkgs- SearchDepth d -> opts `set` optSearchDepth := d+ SegmentSize s -> opts `set` optSegmentSize := s SaveReflectDump f -> opts `set` optSaveReflectDump := f LoadReflectDump f -> opts `set` optLoadReflectDump := f TargetDirectory t -> opts `set` optTargetDirectory := t+ CabalPresetFile f -> opts `set` optCabalPreset := f main :: IO () -- ^ main: parseArgs and either 'run' or show errors.@@ -123,9 +128,9 @@ | opts `get` optShowHelp = do progName <- getProgName putStrLn (usageInfo ((\_ -> let { __ = -{-# LINE 120 "Main.hss" #-}+{-# LINE 125 "Main.hss" #-} concat ["", (versionInfo), "\n\nUsage: ", (progName), " [options]\n\n", (helpText), "\n"]-{-# LINE 126 "Main.hss" #-}+{-# LINE 131 "Main.hss" #-} } in __) undefined) options) | opts `get` optShowVersion = putStrLn versionInfo@@ -134,9 +139,9 @@ else j2hs opts (filter justJava javaClassesSE6) | otherwise = getProgName >>= \progName -> putStr ((\_ -> let { __ = -{-# LINE 133 "Main.hss" #-}+{-# LINE 138 "Main.hss" #-} concat ["No command given. Use `", (progName), " help' for help.\n"]-{-# LINE 135 "Main.hss" #-}+{-# LINE 140 "Main.hss" #-} } in __) undefined) where justJava = ("java" `isPrefixOf`)
+ dist/build/j2hs/j2hs-tmp/Segments.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE Haskell2010 #-}+{-# OPTIONS+ -Wall+ -fno-warn-name-shadowing+ #-}++-- | Functions for partitioning package dependency graphs and+-- class dependency graphs.+module Segments where++import Prelude hiding (print)++import Types+import Utils++import Control.Monad++import Haskell.X+import Foreign.Java+import Foreign.Java.IO++import Data.Graph+import Data.Tree++import Data.Map (Map)+import MultiMap (MultiMap)+import Data.Set (Set)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified MultiMap as MultiMap++import System.IO hiding (print)++-- Finds strongly connected components in the dependencies graph+-- between classes and groups them in independent ranks, i.e.+-- two scc within the same rank are mutually independent.+findClassClusters+ :: Map String JavaClass+ -> Java [[[String]]]+findClassClusters classInfo = do+ + print "Attempting to find clusters... "+ + let edges = Map.foldlWithKey mkNode [] classInfo+ mkNode vs name clazz = (name, name, classDependencies clazz) : vs+ (graph, label, _) = graphFromEdges edges++ components :: [[Vertex]]+ components = map flatten $ scc graph+ + ranks :: [[[Vertex]]]+ ranks = let (a, b) = foldl rank (Set.empty, []) components+ in if Set.null a then b+ else Set.toList a : b++ rank :: (Set [Vertex], [[[Vertex]]]) -> [Vertex]+ -> (Set [Vertex], [[[Vertex]]])+ rank (rs, vss) vs+ | Set.null ins = (Set.insert vs rs, vss)+ | otherwise = (Set.singleton vs, vss')+ where deps = Set.fromList (concatMap (reachable graph) vs)+ ins = deps `Set.intersection` Set.fromList (Set.foldr (++) [] rs)+ vss' = if Set.null rs then vss else Set.toList rs : vss++ labeledRanks = reverse $ map (map (map (\x -> let (z,_,_) = label x in z))) ranks+ numClusters = sum (map length labeledRanks)+ numRanks = length labeledRanks++ println ((\_ -> let { __ = +{-# LINE 69 "Segments.hss" #-}+concat ["Done (found ", (show $ numClusters), " strongly connected components in ", (show $ numRanks), " ranks)."]+{-# LINE 70 "Segments.hss" #-}+} in __) undefined)++ return labeledRanks+++-- Find strongly connected components in the dependencies graph+-- between packages.+findPackageClusters+ :: MultiMap String String+ -> Map String JavaClass+ -> Java [[String]]+findPackageClusters classesByPackage classInfo = do+ + let packageDependencies :: Map String (Set String)+ packageDependencies = Map.map findDependencies (MultiMap.toMap classesByPackage)+ where+ findDependencies classes = Set.fromList packageDependencies+ where+ dependencies = concatMap (classDependencies . (classInfo Map.!)) classes+ packageDependencies = map (fst . splitClassName) dependencies++ graph = Map.foldlWithKey mkNode [] packageDependencies+ mkNode vs name deps = (name, name, Set.toList deps) : vs+ scc = map flattenSCC (stronglyConnComp graph)++ return $ reverse scc+++-- Find the core packages of Java by resolving all dependencies+-- of all packages and taking the intersection of all these sets.+findJavaCore+ :: MultiMap String String+ -> Map String JavaClass+ -> Java (Set String)+findJavaCore classesByPackage classInfo = do++ let packageDependencies :: Map String (Set String)+ packageDependencies = Map.map findDependencies (MultiMap.toMap classesByPackage)+ where+ findDependencies classes = Set.fromList packageDependencies+ where+ dependencies = concatMap (classDependencies . (classInfo Map.!)) classes+ packageDependencies = map (fst . splitClassName) dependencies++ resolve :: Set String -> Set String+ resolve = Set.fromList . concatMap (Set.toList . (packageDependencies Map.!)) . Set.toList++ fullPackageDependencies = Map.map (exhaustively resolve) packageDependencies++ coreJava = intersections (Map.elems fullPackageDependencies)++ return coreJava+++-- This creates a graphviz file which can be used to+-- visualize inter-package dependencies+visualizeDependencies+ :: Map String (Set String)+ -> IO ()+visualizeDependencies packageDependencies = do++ file <- openFile "dependencies.neato" WriteMode+ hPutStrLn file ((\_ -> let { __ = +{-# LINE 132 "Segments.hss" #-}+concat ["digraph G {\n overlap = false;"]+{-# LINE 132 "Segments.hss" #-}+} in __) undefined)++ forM_ (Map.toList packageDependencies) $ \(pkg, deps) -> do+ forM_ (Set.toList deps) $ \dep -> do+ let augment = map (\x -> if x == '.' then '_' else x)+ pkg' = augment pkg+ dep' = augment dep+ hPutStr file ((\_ -> let { __ = +{-# LINE 139 "Segments.hss" #-}+concat [" ", (pkg'), " -> ", (dep'), "\n"]+{-# LINE 139 "Segments.hss" #-}+} in __) undefined)++ hPutStrLn file ((\_ -> let { __ = +{-# LINE 141 "Segments.hss" #-}+concat ["}"]+{-# LINE 141 "Segments.hss" #-}+} in __) undefined)+ hClose file++
− dist/build/j2hs/j2hs-tmp/Translate.hs
@@ -1,344 +0,0 @@-{-# 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)--
j2hs.cabal view
@@ -1,5 +1,5 @@ name: j2hs-version: 0.9.1+version: 0.99 license: MIT license-file: LICENSE@@ -24,29 +24,29 @@ main-is: Main.hs other-modules: Options+ , Types , Java2Haskell , JavaSE6- , Translate- , Typomatic- , Bindings+ , Segments+ , CodeGen.Typomatic+ , CodeGen.Class+ , CodeGen.JavaBindings , Utils build-depends: base >= 4.5 && < 5- , hinduce-missingh- , java-bridge == 0.9- , java-bridge-extras == 0.9- , java-reflect == 0.9- , haskell-reflect == 0.9+ , hx >= 0.3+ , java-bridge == 0.99+ , java-bridge-extras == 0.99+ , java-reflect == 0.99 , split >= 0.2.1.1 , named-records >= 0.5 , filepath >= 1.3 , directory >= 1.1.0.2 , containers >= 0.4.2.1 , bimap >= 0.2.4- , multimap >= 1.2 , syb >= 0.3.6.1 , strings >= 1.1 , mtl >= 2.1.1 , transformers >= 0.3-+ , strict >= 0.3.2
− src/Bindings.hss
@@ -1,163 +0,0 @@-{-# LANGUAGE Haskell2010 #-}-{-# OPTIONS -Wall #-}---- | Functions for generating glue code between Haskell and Java.-module Bindings (-- -- * Create Haskell glue code from Java definitions- printJavaPackageModule,- printJavaClassModule,- printJavaClassBootfile,- printJavaClassModule',- printJavaClassBootfile',-- ) where--import Translate-import Foreign.Java.Utils-import Language.Java.Reflect.Types--import Data.Map (Map)--imports :: String--- ^ Imports of all auto generated java code files.-imports = """- import qualified Foreign.Java as JNI- import Foreign.Java ((-->))- import qualified Prelude as Prelude- import Prelude ((.), ($), (>>=), (>>), return)- import qualified Foreign.Java.Bindings as JNIS- import Data.Functor ((<$>))- """--classInfoSignature :: String--- ^ -classInfoSignature = "Prelude.String"--classInfo' :: JavaClass -> String--- ^ -classInfo' clazz = className clazz--packageInfo' :: String -> a -> String-packageInfo' packageName classes = packageName--printJavaPackageModule :: String -- The Java package name- -> String -- The Haskell module name of the Java package- -> Map String JavaClass -- Info about all other classes- -> [JavaClass] -- The Java classes contained in the Java package- -> String--- ^ -printJavaPackageModule packageName modName classInfo classes = """- {-# LANGUAGE Haskell2010 #-}- -- | Package @#{packageName}@- module #{modName} (- #{moduleExports}\- info'- ) where- #{imports}- #{moduleImports}- -- Information about this package.- info' = #{show $ packageInfo' packageName classes}- #{moduleDeclarations}- """- where moduleDeclarations = pkgModDecl classInfo classes- moduleImports = pkgModImports classInfo classes- moduleExports = pkgModExports classInfo classes---printJavaClassModule :: JavaClass -- The Java class- -> String -- The Haskell module name of the Java class- -> Map String JavaClass -- Info about all classes- -> String--- ^ -printJavaClassModule clazz modName classInfo = """- {-# LANGUAGE Haskell2010 #-}- -- | #{show $ classType clazz} @#{classFullName clazz}@- module #{modName} (- #{moduleExports}\- -- * Information about this class.- info'- ) where- #{imports}- #{bootfileImports}- #{moduleImports}- info' = #{show $ classInfo' clazz}- #{bootfileDeclarations}- #{moduleDeclarations}- """- where bootfileDeclarations = classBootDecl classInfo clazz- bootfileImports = classBootImports classInfo clazz- moduleDeclarations = classModDecl classInfo clazz- moduleImports = classModImports classInfo clazz- moduleExports = classModExports classInfo clazz---printJavaClassBootfile :: JavaClass -- The Java class- -> String -- The Haskell module name of the Java class- -> Map String JavaClass -- Info about all classes- -> String--- ^ -printJavaClassBootfile clazz modName classInfo = """- {-# LANGUAGE Haskell2010 #-}- -- Bootfile for class #{className clazz}- module #{modName} (- #{bootfileExports}\- info'- ) where- #{imports}- #{bootfileImports}- info' :: #{classInfoSignature}- #{bootfileDeclarations}- """- where bootfileDeclarations = classBootDecl classInfo clazz- bootfileImports = classBootImports classInfo clazz- bootfileExports = classBootExports classInfo clazz---printJavaClassModule' :: JavaClass -- The Java class- -> String -- The Haskell module name of the Java class- -> Map String JavaClass -- Info about all classes- -> String--- ^ -printJavaClassModule' clazz modName classInfo = """- {-# LANGUAGE Haskell2010, TypeFamilies #-}- -- hidden @#{className clazz}@- module #{modName}__ (- #{moduleExports}\- info'- ) where- #{imports}- #{bootfileImports}- #{moduleImports}- info' = #{show $ classInfo' clazz}- #{bootfileDeclarations}- #{moduleDeclarations}- """- where bootfileDeclarations = classBootDecl' classInfo clazz- bootfileImports = classBootImports' classInfo clazz- moduleDeclarations = classModDecl' classInfo clazz- moduleImports = classModImports' classInfo clazz- moduleExports = classModExports' classInfo clazz---printJavaClassBootfile' :: JavaClass -- The Java class- -> String -- The Haskell module name of the Java class- -> Map String JavaClass -- Info about all classes- -> String--- ^ -printJavaClassBootfile' clazz modName classInfo = """- {-# LANGUAGE Haskell2010 #-}- -- hidden Bootfile for class #{className clazz}- module #{modName}__ (- #{bootfileExports}\- info'- ) where- #{imports}- #{bootfileImports}- info' :: #{classInfoSignature}- #{bootfileDeclarations}- """- where bootfileDeclarations = classBootDecl' classInfo clazz- bootfileImports = classBootImports' classInfo clazz- bootfileExports = classBootExports' classInfo clazz-
+ src/CodeGen/Class.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE Haskell2010+ , GeneralizedNewtypeDeriving+ #-}+{-# OPTIONS -Wall #-}++module CodeGen.Class where++import Types++import Control.Monad.Reader++import qualified Haskell.X as X++type CodeGenerator m = CodeGen m String++newtype CodeGen m a = CodeGen { _runBG :: ReaderT ClassInfo m a }+ deriving (Monad, MonadReader ClassInfo, Functor)+++gen :: Monad m => ClassInfo -> CodeGenerator m -> m String+gen info generator = runReaderT (_runBG generator) info+++getModNameForClass :: Monad m => String -> CodeGen m String+getModNameForClass clazz = do+ info <- ask+ return $ info `classModName` clazz+ +getModNameForPackage :: Monad m => String -> CodeGen m String+getModNameForPackage package = do+ info <- ask+ return $ info `packageModName` package++getClassInfoFor :: Monad m => String -> CodeGen m JavaClass+getClassInfoFor clazz = do+ info <- ask+ return $ info `aboutClass` clazz++getClassInfoFunc :: Monad m => CodeGen m (String -> JavaClass)+getClassInfoFunc = ask >>= return . aboutClass++getClassModFunc :: Monad m => CodeGen m (JavaClass -> String)+getClassModFunc = do+ info <- ask+ return (classModName info . className)++getClasses :: Monad m => CodeGen m [String]+getClasses = do+ info <- ask+ return $ allClasses info++getPackages :: Monad m => CodeGen m [String]+getPackages = do+ info <- ask+ return $ allPackages info++getClassesForPackage :: Monad m => String -> CodeGen m [String]+getClassesForPackage package = do+ info <- ask+ return $ info `classesForPackage` package++getPackageModuleDeps :: Monad m => String -> CodeGen m [String]+getPackageModuleDeps package = getClassesForPackage package >>= getClassModulesUniq++getClassModules :: Monad m => [String] -> CodeGen m [String]+getClassModules = mapM getModNameForClass++getClassModulesUniq :: Monad m => [String] -> CodeGen m [String]+getClassModulesUniq classes = return (X.uniqSort classes) >>= getClassModules++getClassModuleDeps :: Monad m => JavaClass -> CodeGen m [String]+getClassModuleDeps clazz = getClassModulesUniq (className clazz : classDependencies clazz)++
+ src/CodeGen/JavaBindings.hss view
@@ -0,0 +1,503 @@+{-# 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}+ """++
+ src/CodeGen/Typomatic.hs view
@@ -0,0 +1,481 @@+{-# LANGUAGE Haskell2010+ , GeneralizedNewtypeDeriving+ , DeriveDataTypeable+ #-}+{-# OPTIONS+ -Wall+ -fno-warn-name-shadowing+ #-}++-- | INTERNAL module is used to infer Haskell types from Java types.+module CodeGen.Typomatic (+ runTypomatic,++ methodType,+ getterType,+ setterType,+ constructorType,++ ArgInfo (..),++ printJniType,++ dataTName,+ dataCName,+ newtTName,+ newtCName,+ tyclTName+) where++-- import Utils++import Foreign.Java.Utils+import Language.Java.Reflect+import qualified Language.Java.Reflect.Types as Types++import Control.Monad.State hiding (void)+import qualified Control.Monad.State as State+import Data.Functor.Identity++import Data.Generics+import Data.Strings+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.List as List++import Haskell.X.Ops+++dataTName, dataCName, newtTName, newtCName, tyclTName :: String -> String++dataTName = (++ "''")+dataCName = id -- (++ "")+newtTName = (++ "'")+newtCName = (++ "'")+tyclTName = id -- (++ "")++-- | This is the information which is ultimately+-- gathered by the use of this module.+data ArgInfo = ArgInfo {+ fSignature :: String,+ fArguments :: [TVar],+ fReturnType :: TVar,+ fArgNames :: [String],+ fJavaSignature :: String,+ fJavaReturnType :: String,+ fJniSignature :: String+ }++tr :: Eq a => a -> a -> [a] -> [a]+tr a b (x:xs)+ | a == x = b : tr a b xs+ | otherwise = x : tr a b xs+tr _ _ [] = []++breakLast :: [a] -> ([a], a)+breakLast [a] = ([], a)+breakLast (a:as) =+ let (init', last') = breakLast as+ in (a:init', last')+breakLast _ = error "Foreign.Java.Util.breakLast: empty list"+++--------------------+-- Type variables --+--------------------++data TVar = TVar String | TVars [TVar]+ deriving (Eq, Ord, Show, Data, Typeable)++printTVar :: TVar -> String+printTVar var = case var of+ (TVar v) -> v+ (TVars vs) -> concat ["(", tail (concatMap ((' ':) . printTVar) vs), ")"]+++---------------+-- Utilities --+---------------++printJniType :: JavaType -> String+printJniType t = case t of+ JBoolean -> "JNI.boolean"+ JChar -> "JNI.char"+ JByte -> "JNI.byte"+ JShort -> "JNI.short"+ JInt -> "JNI.int"+ JLong -> "JNI.long"+ JFloat -> "JNI.float"+ JDouble -> "JNI.double"+ JObj n -> "JNI.object \"" ++ n ++ "\""+ -- arrays are treated as objects:+ JArr c -> "JNIS.object' \"[" ++ printJniRawType c ++ "\""+++printJniRawType :: JavaType -> String+printJniRawType t = case t of+ JBoolean -> "Z"+ JChar -> "C"+ JByte -> "B"+ JShort -> "S"+ JInt -> "I"+ JLong -> "J"+ JFloat -> "F"+ JDouble -> "D"+ JObj n -> 'L' : tr '.' '/' n ++ ";"+ JArr c -> '[' : printJniRawType c+++printJniSignature :: JavaMethod -> String+printJniSignature method = show name ++ " JNI.::= " ++ args ++ ret+ where+ name = methodName method+ args = concatMap ((++ " --> ") . printJniType) (map fst $ methodParams method)+ ret = maybe "JNI.void" printJniType (fst $ methodReturnType method)++typeclassFor :: String -> String+typeclassFor name = name ++ "__." ++ tyclTName (takeClassName name)++newtypeFor :: String -> String+newtypeFor name = name ++ "__." ++ newtTName (takeClassName name)++jtypeForClass :: JavaClass -> JavaType+jtypeForClass clazz = JObj (className clazz)++gtypeForClass :: JavaClass -> JavaGenericType+gtypeForClass clazz+ | null (classTypeParams clazz) = NotSoGeneric+ | otherwise = Parameterized {+ jgtBasetype = className clazz,+ jgtParameters = map (TypeVarReference . paramName) (classTypeParams clazz)+ }++constructorType :: JavaClass -> JavaConstructor -> (JavaClass -> String) -> Typomatic ArgInfo+constructorType clazz constr modNameFor = do+ let method = JavaMethod {+ methodName = "", methodName' = "",+ methodParams = constructorParams constr,+ methodReturnType = (Just (jtypeForClass clazz), gtypeForClass clazz),+ methodExceptions = constructorExceptions constr,+ methodTypeParams = constructorTypeParams constr,+ methodStatic = True, methodFinal = True,+ methodAbstract = False, methodNative = False, methodSynchronized = False+ }+ result <- methodType clazz method modNameFor+ let jniSig = fJniSignature result ->> strSplitAll " --> " ->> init ->> strJoin " --> "+ return $ result {+ fJniSignature = drop 11 jniSig+ }++getterType :: JavaClass -> JavaField -> (JavaClass -> String) -> Typomatic ArgInfo+getterType clazz field modNameFor = do+ let isStatic = fieldStatic field+ (jtype, gtype) = fieldType field+ method = JavaMethod {+ methodName = "", methodName' = "",+ methodParams = [],+ methodReturnType = (Just jtype, gtype),+ methodExceptions = [], methodTypeParams = [],+ methodStatic = isStatic, methodFinal = fieldFinal field,+ methodAbstract = False, methodNative = False, methodSynchronized = False+ }+ methodType clazz method modNameFor++setterType :: JavaClass -> JavaField -> (JavaClass -> String) -> Typomatic ArgInfo+setterType clazz field modNameFor = do+ let isStatic = fieldStatic field+ method = JavaMethod {+ methodName = "", methodName' = "",+ methodParams = [fieldType field],+ methodReturnType = (Just (JObj "@()"), NotSoGeneric),+ methodExceptions = [], methodTypeParams = [],+ methodStatic = isStatic, methodFinal = fieldFinal field,+ methodAbstract = False, methodNative = False, methodSynchronized = False+ }+ methodType clazz method modNameFor+ +methodType :: JavaClass -> JavaMethod -> (JavaClass -> String) -> Typomatic ArgInfo+methodType clazz method_ modNameFor = do++ let className = Types.className clazz+ classParams = classTypeParams clazz++ -- sanitize tyVars tied to the method by distinguishing+ -- from tyVars tied to the class by adding an apostrophe+ -- to the name of the tyVar if it is tied to the method.+ methodTypeVars = map paramName (methodTypeParams method_)+ safe var@(TyVar str)+ | var `elem` methodTypeVars = TyVar (str ++ "'")+ | otherwise = var+ method = everywhere (mkT safe) method_++ -- the following three functions create the list of+ -- argument parameters, including @this@ (if the method+ -- is not static) and the return type. The return type+ -- is separated later on again.+ thisParam = if null classParams+ then NotSoGeneric+ else Parameterized {+ jgtBasetype = className,+ jgtParameters = (map (TypeVarReference . paramName) classParams)+ }+ params = (if methodStatic method then [] else [thisParam])+ ++ map snd (methodParams method)+ ++ [maybe (TypeVarReference (TyVar "()"))+ (const $ snd $ methodReturnType method)+ (fst $ methodReturnType method)]+ jtypes = (if methodStatic method then [] else [JObj className])+ ++ map fst (methodParams method)++ -- turns a JavaGenericType definition into type variables.+ -- The names are taken from the monad via 'newVar'.+ tvar param = case jgtType param of+ WildcardT -> do+ name <- newVar+ return $ TVar name+ ParameterizedT -> do+ name <- newVar+ params <- mapM tvar (jgtParameters param)+ return $ TVars $ TVar name : params+ GenericArrayT -> do+ name <- newVar+ return $ TVar name+ TypeVarReferenceT -> do+ let name = (tyVarName (jgtName param))+ return $ TVar name+ NotSoGenericT -> do+ name <- newVar+ return $ TVar name++ -- creates a haskell signature (-> String)+ signature typeVars returnVar = do+ -- retrieve the context and turn each variable into a String.+ contexts <- getContext >>= mapM (\(tvar, context) -> do+ return $ context ++ " " ++ printTVar tvar)++ let argTypes = concatMap ((++ " -> ") . printTVar) typeVars+ -- the final type is wrapped in the Java monad+ returnType = "JNI.Java " ++ printTVar returnVar+ -- finally assemble the conetext.+ context = if null contexts then "" else+ "(" ++ concat (List.intersperse ", " contexts) ++ ") => "+ + -- return the full signature, consisting of the context,+ -- the type of the arguments, and the return type.+ return $ concat [context, argTypes, returnType]++ -- create a java signature (-> String)+ javaSignature = do+ let name = methodName method+ args = map printJavaType $ map fst $ methodParams method+ return $ name ++ "(" ++ concat (List.intersperse ", " args) ++ ")"+ ++ -- if this is not a static method the first argument+ -- is /this/. This merely pushed the name into the list+ -- of type variable names in the monad.+ when (not $ methodStatic method) (pushVar "this")++ -- get type variables for all arguments, including the+ -- return type (as the return type may be the same as+ -- one of the argument types).+ --+ -- Split the result into arguments and return var again,+ -- since the return variable will get special treatment+ -- henceforth.+ (typeVars, returnVar_) <- breakLast <$> mapM tvar params++ -- augment the return type variable, i.e. if it is not+ -- a type variable at all, replace the variable name by+ -- a constant reference to a specific type.+ --+ -- This is only the case with parameterized type variables+ -- and not-so-generic ones.+ returnVar <- case fst (methodReturnType method) of+ Just (JObj typeName) -> case jgtType (snd $ methodReturnType method) of+ ParameterizedT -> do+ clazz <- getClass typeName+ let (TVars (TVar _ : ts)) = returnVar_+ return $ TVars (TVar (newtypeFor (modNameFor clazz)) : ts)+ NotSoGenericT -> do+ clazz <- getClass typeName+ return $ TVar (newtypeFor (modNameFor clazz))+ _ -> return returnVar_+ _ -> return returnVar_++ -- Add contexts for all arguments and augment types+ let makeContext typeVar jtype = case jtype of+ JObj ('@':tv) -> return (TVar tv)+ JObj name -> do+ clazz <- getClass name+ addContext typeVar $ typeclassFor $ modNameFor clazz+ return typeVar+ JArr componentType -> do+ addContext typeVar "JNIS.Array"+ return typeVar+ JBoolean -> do+ addContext typeVar "JNIS.JBoolean"+ return typeVar+ JChar -> do+ addContext typeVar "JNIS.JChar"+ return typeVar+ JByte -> do+ addContext typeVar "JNIS.JByte"+ return typeVar+ JShort -> do+ addContext typeVar "JNIS.JShort"+ return typeVar+ JInt -> do+ addContext typeVar "JNIS.JInt"+ return typeVar+ JLong -> do+ addContext typeVar "JNIS.JLong"+ return typeVar+ JFloat -> do+ addContext typeVar "JNIS.JFloat"+ return typeVar+ JDouble -> do+ addContext typeVar "JNIS.JDouble"+ return typeVar++ -- Here makeContexts is applied (see above). In the same pass a new+ -- set of typeVars (typeVars') is generated, since makeContexts+ -- migth further investigate array and create type variables for+ -- their component types.+ typeVars' <- mapM (uncurry makeContext) (zip typeVars jtypes)++ -- Create contexts for the ultimate return type.+ returnVar' <- case fst (methodReturnType method) of+ Nothing -> do+ let tvar = TVar "void"+ addContext tvar "JNIS.VoidResult"+ return tvar+ Just t -> case t of+ JObj ('@':tv) -> return (TVar tv)+ JObj _ -> do+ let tvar = TVars [TVar "object", returnVar]+ addContext tvar "JNIS.ObjectResult"+ return tvar+ JArr _ -> do+ let tvar = TVar "JNI.JObject"+-- addContext tvar "JNIS.ArrayResult"+ return tvar+ JBoolean -> do+ let tvar = TVar "boolean"+ addContext tvar "JNIS.BooleanResult"+ return tvar+ JChar -> do+ let tvar = TVar "char"+ addContext tvar "JNIS.CharResult"+ return tvar+ JByte -> do+ let tvar = TVar "byte"+ addContext tvar "JNIS.ByteResult"+ return tvar+ JShort -> do+ let tvar = TVar "short"+ addContext tvar "JNIS.ShortResult"+ return tvar+ JInt -> do+ let tvar = TVar "int"+ addContext tvar "JNIS.IntResult"+ return tvar+ JLong -> do+ let tvar = TVar "long"+ addContext tvar "JNIS.LongResult"+ return tvar+ JFloat -> do+ let tvar = TVar "float"+ addContext tvar "JNIS.FloatResult"+ return tvar+ JDouble -> do+ let tvar = TVar "double"+ addContext tvar "JNIS.DoubleResult"+ return tvar++ -- generate the Haskell signature (a String)+ sig <- signature typeVars' returnVar'++ -- generate the Java signature (a String).+ -- This is used for documentation purposed later on+ -- (i.e. inserted as haddock docstring).+ jsig <- javaSignature++ -- generate the names of the arguments+ let argNames = (if methodStatic method then id else ("this":) . init)+ $ zipWith (\_ i -> 'a' : show i) typeVars [(1 :: Integer)..]++ -- assemble and return all the calculated information+ return $ ArgInfo {+ fArguments = typeVars,+ fReturnType = returnVar',+ fArgNames = argNames,+ fSignature = sig,+ fJavaSignature = jsig,+ fJavaReturnType = maybe "void" printJavaType (fst $ methodReturnType method),+ fJniSignature = printJniSignature method+ }++--------------------------------------------+-- The following are utilities for the monad+--------------------------------------------++-- | The state of the monad.+data TypomaticState = TypomaticState {+ tVars :: [String],+ tContext :: Set (TVar, String),+ tParams :: [String],+ tClasses :: String -> JavaClass+ }++-- | Retrieve the definition of a class.+--+-- The monad has an internal store of class names+-- and their definitions. See 'tClasses'.+getClass :: String -> Typomatic JavaClass+getClass name = do+ state <- State.get+ return (tClasses state name)++-- | Get the current context as a list.+getContext :: Typomatic [(TVar, String)]+getContext = State.get >>= return . Set.toList . tContext++-- | Add a context for a specific type variable.+addContext :: TVar -> String -> Typomatic ()+addContext tvar string = do+ state <- State.get+ State.put (state {tContext = ((tvar, string) `Set.insert` tContext state)})++-- | Introduce a new name.+--+-- This simply takes the next element in the infinite+-- 'tVars' list and stores the tail back in the monad.+newVar :: Typomatic String+newVar = do+ state <- State.get+ let (v:vs) = tVars state+ State.put (state { tVars = vs})+ return v++-- | Push a new name in the front of the available names.+pushVar :: String -> Typomatic ()+pushVar name = do+ state <- State.get+ State.put (state {tVars = (name : tVars state)})++-- | The monad.+newtype Typomatic a = Typomatic { _runTypomatic :: StateT TypomaticState Identity a }+ deriving (Monad, MonadState TypomaticState, Functor)++-- | Run a computation in the monad.+runTypomatic :: (String -> JavaClass) -> Typomatic a -> a+runTypomatic infoFunc =+ let state = TypomaticState { -- initial state+ tVars = map (('v':) . show) [(1 :: Integer)..],+ tContext = Set.empty,+ tParams = [],+ tClasses = infoFunc+ } in fst . runIdentity . flip runStateT state . _runTypomatic++
src/Java2Haskell.hss view
@@ -13,11 +13,13 @@ import Prelude hiding (print) import Options-import Bindings import Utils+import Types+import Segments+import CodeGen.Class+import CodeGen.JavaBindings import Foreign.Java-import Foreign.Java.Utils import Foreign.Java.IO import Language.Java.Reflect@@ -28,22 +30,25 @@ import Data.Generics -import Data.Bimap (Bimap) import Data.Map (Map)-import Data.MultiMap (MultiMap)-import Data.Set (Set)+import MultiMap (MultiMap) import qualified Data.Map as Map import qualified Data.Set as Set-import qualified Data.MultiMap as MultiMap+import qualified MultiMap as MultiMap +import Control.Applicative import Control.Monad import Control.Monad.IO.Class import System.Directory import System.FilePath import System.IO hiding (print)+import qualified System.IO.Strict as Strict import System.Exit +import Haskell.X++ ifVerbose :: MonadIO m => Options@@ -51,22 +56,39 @@ -> m () ifVerbose opts = when (opts `get` optVerbose) . liftIO . putStr +-- | Invoked by Main.main, the core functionality j2hs :: Options -> [String] -> IO () j2hs opts args = do - classpath <- mapM canonicalizePath $ opts `get` optClasspath- targetDir <- return (opts `get` optTargetDirectory)- let reflectDump_ = opts `get` optLoadReflectDump- reflectDump <- if null reflectDump_+ let augmentEnvironment = do+ targetDir <- return (opts `get` optTargetDirectory)+ createDirectoryIfMissing True targetDir++ classpath <- mapM canonicalizePath $ opts `get` optClasspath++ cabalExtra <- if null (opts `get` optCabalPreset)+ then return ""+ else Strict.readFile (opts `get` optCabalPreset)++ setCurrentDirectory targetDir++ return $ opts+ `set` optClasspath := classpath+ `set` optTargetDirectory := targetDir+ `set` optCabalExtra := cabalExtra++ reflectDump <- if null (opts `get` optLoadReflectDump) then return Nothing- else canonicalizePath reflectDump_ >>= return . Just+ else Just <$> canonicalizePath (opts `get` optLoadReflectDump) - let classpath' = concat $ L.intersperse ":" classpath- indent = (" " ++)+ opts <- augmentEnvironment + let classpath = opts `get` optClasspath+ classpath' = concat $ L.intersperse ":" classpath+ ifVerbose opts """ Classpath: #{concatMap (\x -> " " ++ x ++ "\n") (classpath)}"""@@ -78,25 +100,23 @@ io $ do ifVerbose opts """ Target Directory:- #{targetDir}+ #{opts `get` optTargetDirectory} """- createDirectoryIfMissing True targetDir- setCurrentDirectory targetDir ifVerbose opts """ Looking for Java classes: #{concatMap (\x -> " " ++ x ++ "\n") args}""" - -- Gather all classes that need to be translated- print "Looking up classes..."- classes <- findClasses (opts `get` optSearchDepth) args+ classInfo <- gatherClassInfo opts reflectDump args - println """ #{show $ length classes} found."""- ifVerbose opts $- unlines (map indent classes)+ when (opts `get` optOnlyReflect) $ io $ do+ mapM_ println $ Map.elems classInfo+ exitSuccess -- Calculate the Haskell module names for packages and classes- let packages = Set.toList $ Set.fromList+ let classes = Map.keys classInfo++ packages = Set.toList $ Set.fromList $ map (maybe "" id . takePackageName) classes -- temporary class names@@ -115,6 +135,12 @@ || n `xMemberR` all) $ iterate (++ "Package") modName + bimapCheckedLookup bimap name+ = maybe (error """Failed lookup in Bimap: #{show name}.""") id $ xLookup bimap name++ mapCheckedLookup map name+ = maybe (error """Failed lookup in Map: #{show name}""") id $ name `Map.lookup` map+ -- finally the class names. -- This func keeps in mind that the package names might have been augmented -- before. i.e. the package java.awt.image will be Java.Awt.ImagePackage now,@@ -125,100 +151,74 @@ = (clazzName, joinClassName (newPackageName, classModuleName)) where classModuleName = takeClassName moduleName packageName = maybe "" id $ takePackageName clazzName- newPackageName = packageModules `xGet` packageName+ newPackageName = bimapCheckedLookup packageModules packageName -- A mapping from packages to classes classesByPackage :: MultiMap String String classesByPackage = MultiMap.fromList $ map (\clazz -> (fst $ splitClassName clazz, clazz)) classes - -- The list of hidden modules- hiddenModules = map (++ "__") $ Map.elems classModules-- classInfo <- gatherClassInfo opts reflectDump classModules-- findJavaCore classesByPackage classInfo-- when (opts `get` optOnlyReflect) $ io $ do- mapM_ println $ Map.elems classInfo- exitSuccess-- generateModules opts classInfo classesByPackage classModules packageModules hiddenModules-- return ()--{--findJavaCore2- :: Map String JavaClass- -> Java ()-findJavaCore2 classInfo = do-- let classes = --}--findJavaCore- :: MultiMap String String- -> Map String JavaClass- -> Java ()-findJavaCore classesByPackage classInfo = do-- let packageDependencies :: Map String (Set String)- packageDependencies = Map.map findDependencies (MultiMap.toMap classesByPackage)- where- findDependencies classes = Set.fromList packageDependencies- where- dependencies = concatMap (classDependencies . (classInfo Map.!)) classes- packageDependencies = map (fst . splitClassName) dependencies+ -- Find a suitable segmentation+ rankedClusters <- findClassClusters classInfo - resolve :: Set String -> Set String- resolve = Set.fromList . concatMap (Set.toList . (packageDependencies Map.!)) . Set.toList+ let segmentSize = min (fromIntegral (opts `get` optSegmentSize)) (Map.size classInfo)+ segments = segment3 segmentSize rankedClusters+ lengths = concat $ L.intersperse ", " $ map (show . length) segments - fullPackageDependencies = Map.map (exhaustively resolve) packageDependencies+ println """Identified #{show $ length segments} segments of lengths (#{lengths}).""" - coreJava = intersections (Map.elems fullPackageDependencies)+ -- Assemble the class info+ let info = ClassInfo {+ aboutClass = mapCheckedLookup classInfo,+ classesForPackage = flip MultiMap.lookup classesByPackage,+ classModName = mapCheckedLookup classModules,+ packageModName = bimapCheckedLookup packageModules,+ allClasses = Map.keys classModules,+ allPackages = xKeys packageModules+ } - println (show $ Set.size coreJava)- println (Set.toList coreJava)+ -- Create the code files.+ let pName = opts `get` optProjectName+ pVersion = opts `get` optProjectVersion+ mkDeps = map (\i -> pName ++ "-part" ++ show i ++ " == " ++ pVersion) - forM_ (Map.toList fullPackageDependencies) $ \(pkg, deps) -> do- let deps' = (deps Set.\\ coreJava)- print """- #{pkg}, #{show $ Set.size deps'} (#{show $ Set.size deps}) dependencies:- """- println $ Set.toList deps'+ cwd <- io $ getCurrentDirectory+ forM_ (zip [1 :: Int ..] segments) $ \(i, segment) -> do+ io $ do+ setCurrentDirectory cwd+ createDirectoryIfMissing True (show i)+ setCurrentDirectory (show i)+ let opts' = opts+ `upd` optProjectName := (++ "-part" ++ show i)+ `upd` optDependencies := (++ mkDeps [1..pred i])+ generateClassModules opts' info segment+ io $ setCurrentDirectory cwd + let deps = mkDeps [1..length segments]+ generatePackageModules (opts `upd` optDependencies := (++ deps)) info (allPackages info)+ return () --- Gather information about classes via Reflection--- or (depending on the opts set) from a dump file.+-- | Gather information about classes via Reflection+-- or (depending on the options set) from a dump file. gatherClassInfo :: Options -> Maybe FilePath- -> Map String String+ -> [String] -> Java (Map String JavaClass)-gatherClassInfo opts reflectDump classModules = do+gatherClassInfo opts reflectDump classNames = do - print """Gathering refection information..."""- let classNames = Map.keys classModules- updName name clazz = (name, clazz { classModName = classModules Map.! name })+ reflectClasses <- getReflectClasses - getClassInfo :: Java (Map String JavaClass)- getClassInfo = Map.fromList- `fmap` map (uncurry updName)- `fmap` zip classNames- `fmap` everywhere (mkT (\(TyVar v) -> TyVar ('_':v)))- `fmap` reflectClasses classNames+ print """Gathering reflection information..."""+ let getClassInfo :: Java (Map String JavaClass)+ getClassInfo = everywhere (mkT (\(TyVar v) -> TyVar ('_':v)))+ `fmap` reflectClasses True classNames readClassInfo :: String -> Java (Map String JavaClass)- readClassInfo reflectFile = io $ do- file <- openFile reflectFile ReadMode- contents <- hGetContents file- let contents' = read contents- result <- contents' `seq` return contents'- hClose file- return result+ readClassInfo file = io $ Strict.readFile file >>= return . read classInfo <- maybe getClassInfo (\f -> print " (from dump)" >> readClassInfo f) reflectDump- println " Done."+ println """ Done (found #{show $ Map.size classInfo} classes).""" unless (null (opts `get` optSaveReflectDump)) $ io $ do file <- openFile (opts `get` optSaveReflectDump) WriteMode@@ -229,96 +229,111 @@ return classInfo ---- This creates a graphviz file which can be used to--- visualize inter-package dependencies-visualizeDependencies- :: Map String (Set String)- -> IO ()-visualizeDependencies packageDependencies = do-- file <- openFile "dependencies.neato" WriteMode- hPutStrLn file """digraph G {\n overlap = false;"""-- forM_ (Map.toList packageDependencies) $ \(pkg, deps) -> do- forM_ (Set.toList deps) $ \dep -> do- let augment = map (\x -> if x == '.' then '_' else x)- pkg' = augment pkg- dep' = augment dep- hPutStr file """ #{pkg'} -> #{dep'}\n"""-- hPutStrLn file """}"""- hClose file---- This actually creates the Haskell module files-generateModules+-- This actually creates the Haskell module files for packages+generatePackageModules :: Options- -> Map String JavaClass- -> MultiMap String String- -> Map String String- -> Bimap CaseInsensitiveString CaseInsensitiveString+ -> ClassInfo -> [String] -> Java ()-generateModules opts classInfo classesByPackage classModules packageModules hiddenModules = do-- println """Generating modules for #{show $ Map.size classModules} classes in \- #{show $ xSize packageModules} packages..."""+generatePackageModules opts info packages = do - -- A list of all modules- let allModules = xKeysR packageModules ++ Map.elems classModules+ cwd <- io $ getCurrentDirectory+ print """Generating modules for #{show $ length packages} packages in #{cwd}...""" -- Create all the package files. -- These contain the Java classes as Haskell types.- forM_ (xToList packageModules) $ \(packageName, packageMod) -> do- let dirName = strJoin [pathSeparator] (strSplitAll "." packageMod)+ forM_ packages $ \packageName -> do+ let packageMod = info `packageModName` packageName+ dirName = strJoin [pathSeparator] (strSplitAll "." packageMod) -- Create the directory for the package io $ do createDirectoryIfMissing True dirName - let classes = map (classInfo Map.!)- (MultiMap.lookup packageName classesByPackage)- -- Create the Haskell module file for the Java package file <- openFile (dirName ++ ".hs") WriteMode- hPutStrLn file- $ printJavaPackageModule packageName packageMod classInfo classes+ code <- gen info $ javaPackageModule packageName+ hPutStrLn file code hClose file + when (opts `get` optCabalProject)+ $ writeCabalFile+ (opts `get` optProjectName)+ (opts `get` optProjectVersion)+ (opts `get` optCabalExtra)+ (opts `get` optDependencies)+ (map (info `packageModName`) packages)++ println " Done."+++-- This actually creates the Haskell module files for classes+generateClassModules+ :: Options+ -> ClassInfo+ -> [String]+ -> Java ()+generateClassModules opts info classes = do++ cwd <- io $ getCurrentDirectory+ print """Generating modules for #{show $ length classes} classes in #{cwd}..."""+ -- Create all the class files. -- These contain the java methods as Haskell functions.- forM_ (Map.toList classModules) $ \(clazzName, clazzMod) -> do- let fileName = strJoin [pathSeparator] (strSplitAll "." clazzMod)- clazz = classInfo Map.! clazzName+ forM_ classes $ \className -> do+ let fileName = strJoin [pathSeparator] (strSplitAll "." (info `classModName` className))+ dirName = takeDirectory fileName io $ do+ createDirectoryIfMissing True dirName+ -- Create the Haskell module file for the Java class. file <- openFile (fileName ++ ".hs") WriteMode- hPutStrLn file $ printJavaClassModule clazz clazzMod classInfo+ code <- gen info $ javaClassModule className+ hPutStrLn file code hClose file - -- Create the *hidden* Haskell module file for the Java class.+ -- Create the interface Haskell module file for the Java class. file <- openFile (fileName ++ "__.hs") WriteMode- hPutStrLn file $ printJavaClassModule' clazz clazzMod classInfo+ code <- gen info $ javaClassModule' className+ hPutStrLn file code hClose file - -- write Cabal file- when (opts `get` optCabalProject) $ io $ do- cabalFile <- openFile ((opts `get` optProjectName) ++ ".cabal") WriteMode- hPutStrLn cabalFile """- name: #{opts `get` optProjectName}- version: #{opts `get` optProjectVersion}- cabal-version: >= 1.8- build-type: Simple- - Library {- build-depends:- base >= 4 && < 5,- java-bridge- exposed-modules:- #{strJoin ",\n " allModules}- other-modules:- #{strJoin ",\n " hiddenModules} }- """- hClose cabalFile+ let modules = map (info `classModName`) classes+ when (opts `get` optCabalProject)+ $ writeCabalFile+ (opts `get` optProjectName)+ (opts `get` optProjectVersion)+ (opts `get` optCabalExtra)+ (opts `get` optDependencies)+ (modules ++ map (++ "__") modules)++ println " Done."+++-- | Write a cabal project file. Can be used in any MonadIO, e.g. IO or Java or...+writeCabalFile :: MonadIO m =>+ String -- project name+ -> String -- project version+ -> String -- extra + -> [String] -- dependencies+ -> [String] -- public module list+ -> m ()+writeCabalFile projectName projectVersion extra dependencies modules = liftIO $ do++ cabalFile <- openFile (projectName ++ ".cabal") WriteMode+ hPutStrLn cabalFile """+ name: #{projectName}+ version: #{projectVersion}+ cabal-version: >= 1.8+ build-type: Simple+ #{extra}+ Library+ build-depends:+ base >= 4 && < 5\+ #{concatMap (",\n " ++) dependencies}+ exposed-modules:+ #{strJoin ",\n " modules}+ """+ hClose cabalFile
src/Main.hss view
@@ -35,10 +35,11 @@ | Version | Packages [String] | Classpath [String]- | SearchDepth Word32+ | SegmentSize Word32 | TargetDirectory String | SaveReflectDump String | LoadReflectDump String+ | CabalPresetFile String | CompleteSE6 | OnlyReflect | Filtered@@ -58,7 +59,10 @@ Option "P" ["packages"] (ReqArg readPackages "") "The packages to translate.", - Option "d" ["search-depth"] (ReqArg readSearchDepth "")+ Option "p" ["cabal-preset"] (ReqArg CabalPresetFile "")+ "A file containing presets for cabal project files. The contents are included literally.",++ Option "s" ["segment-size"] (ReqArg readSegmentSize "") "The maximum search depth for dependent Java classes.", Option "v" ["verbose"] (NoArg Verbose)@@ -82,7 +86,7 @@ ] where readPackages = Packages . splitOneOf ":;," readClasspath = Classpath . splitOneOf ":;,"- readSearchDepth = SearchDepth . read+ readSegmentSize = SegmentSize . read parseArgs :: IO (Either (Options, [String]) [String]) -- ^ Parse command line arguments with the help of the GetOpt library.@@ -103,10 +107,11 @@ OnlyReflect -> opts `set` optOnlyReflect := True Classpath cp -> opts `set` optClasspath := cp Packages pkgs -> opts `set` optPackages := pkgs- SearchDepth d -> opts `set` optSearchDepth := d+ SegmentSize s -> opts `set` optSegmentSize := s SaveReflectDump f -> opts `set` optSaveReflectDump := f LoadReflectDump f -> opts `set` optLoadReflectDump := f TargetDirectory t -> opts `set` optTargetDirectory := t+ CabalPresetFile f -> opts `set` optCabalPreset := f main :: IO () -- ^ main: parseArgs and either 'run' or show errors.
src/Options.hs view
@@ -15,7 +15,6 @@ `has` "optShowVersion" := False `has` "optPackages" := ["java.lang"] `has` "optClasspath" := ["."]- `has` "optSearchDepth" := (100 :: Word32) `has` "optVerbose" := False `has` "optCompleteSE6" := False `has` "optFiltered" := False@@ -26,4 +25,7 @@ `has` "optCabalProject" := True `has` "optSaveReflectDump" := "" `has` "optLoadReflectDump" := ""-+ `has` "optSegmentSize" := (420 :: Word32)+ `has` "optDependencies" := ["java-bridge"]+ `has` "optCabalExtra" := ""+ `has` "optCabalPreset" := ""
+ src/Segments.hss view
@@ -0,0 +1,144 @@+{-# LANGUAGE Haskell2010 #-}+{-# OPTIONS+ -Wall+ -fno-warn-name-shadowing+ #-}++-- | Functions for partitioning package dependency graphs and+-- class dependency graphs.+module Segments where++import Prelude hiding (print)++import Types+import Utils++import Control.Monad++import Haskell.X+import Foreign.Java+import Foreign.Java.IO++import Data.Graph+import Data.Tree++import Data.Map (Map)+import MultiMap (MultiMap)+import Data.Set (Set)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified MultiMap as MultiMap++import System.IO hiding (print)++-- Finds strongly connected components in the dependencies graph+-- between classes and groups them in independent ranks, i.e.+-- two scc within the same rank are mutually independent.+findClassClusters+ :: Map String JavaClass+ -> Java [[[String]]]+findClassClusters classInfo = do+ + print "Attempting to find clusters... "+ + let edges = Map.foldlWithKey mkNode [] classInfo+ mkNode vs name clazz = (name, name, classDependencies clazz) : vs+ (graph, label, _) = graphFromEdges edges++ components :: [[Vertex]]+ components = map flatten $ scc graph+ + ranks :: [[[Vertex]]]+ ranks = let (a, b) = foldl rank (Set.empty, []) components+ in if Set.null a then b+ else Set.toList a : b++ rank :: (Set [Vertex], [[[Vertex]]]) -> [Vertex]+ -> (Set [Vertex], [[[Vertex]]])+ rank (rs, vss) vs+ | Set.null ins = (Set.insert vs rs, vss)+ | otherwise = (Set.singleton vs, vss')+ where deps = Set.fromList (concatMap (reachable graph) vs)+ ins = deps `Set.intersection` Set.fromList (Set.foldr (++) [] rs)+ vss' = if Set.null rs then vss else Set.toList rs : vss++ labeledRanks = reverse $ map (map (map (\x -> let (z,_,_) = label x in z))) ranks+ numClusters = sum (map length labeledRanks)+ numRanks = length labeledRanks++ println """Done (found #{show $ numClusters} strongly connected \+ components in #{show $ numRanks} ranks)."""++ return labeledRanks+++-- Find strongly connected components in the dependencies graph+-- between packages.+findPackageClusters+ :: MultiMap String String+ -> Map String JavaClass+ -> Java [[String]]+findPackageClusters classesByPackage classInfo = do+ + let packageDependencies :: Map String (Set String)+ packageDependencies = Map.map findDependencies (MultiMap.toMap classesByPackage)+ where+ findDependencies classes = Set.fromList packageDependencies+ where+ dependencies = concatMap (classDependencies . (classInfo Map.!)) classes+ packageDependencies = map (fst . splitClassName) dependencies++ graph = Map.foldlWithKey mkNode [] packageDependencies+ mkNode vs name deps = (name, name, Set.toList deps) : vs+ scc = map flattenSCC (stronglyConnComp graph)++ return $ reverse scc+++-- Find the core packages of Java by resolving all dependencies+-- of all packages and taking the intersection of all these sets.+findJavaCore+ :: MultiMap String String+ -> Map String JavaClass+ -> Java (Set String)+findJavaCore classesByPackage classInfo = do++ let packageDependencies :: Map String (Set String)+ packageDependencies = Map.map findDependencies (MultiMap.toMap classesByPackage)+ where+ findDependencies classes = Set.fromList packageDependencies+ where+ dependencies = concatMap (classDependencies . (classInfo Map.!)) classes+ packageDependencies = map (fst . splitClassName) dependencies++ resolve :: Set String -> Set String+ resolve = Set.fromList . concatMap (Set.toList . (packageDependencies Map.!)) . Set.toList++ fullPackageDependencies = Map.map (exhaustively resolve) packageDependencies++ coreJava = intersections (Map.elems fullPackageDependencies)++ return coreJava+++-- This creates a graphviz file which can be used to+-- visualize inter-package dependencies+visualizeDependencies+ :: Map String (Set String)+ -> IO ()+visualizeDependencies packageDependencies = do++ file <- openFile "dependencies.neato" WriteMode+ hPutStrLn file """digraph G {\n overlap = false;"""++ forM_ (Map.toList packageDependencies) $ \(pkg, deps) -> do+ forM_ (Set.toList deps) $ \dep -> do+ let augment = map (\x -> if x == '.' then '_' else x)+ pkg' = augment pkg+ dep' = augment dep+ hPutStr file """ #{pkg'} -> #{dep'}\n"""++ hPutStrLn file """}"""+ hClose file++
− src/Translate.hss
@@ -1,286 +0,0 @@-{-# 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) -> """ -- * #{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) <- 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' :: 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)--
+ src/Types.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE Haskell2010+ #-}+{-# OPTIONS -Wall #-}++module Types (+ module Foreign.Java.Utils,+ module Language.Java.Reflect.Types,+ ClassInfo (..)+ ) where++import Foreign.Java.Utils+import Language.Java.Reflect.Types++data ClassInfo = ClassInfo {+ aboutClass :: String -> JavaClass,+ classesForPackage :: String -> [String],+ classModName :: String -> String,+ packageModName :: String -> String,+ allClasses :: [String],+ allPackages :: [String]+ }++
− src/Typomatic.hs
@@ -1,411 +0,0 @@-{-# LANGUAGE Haskell2010- , GeneralizedNewtypeDeriving- , DeriveDataTypeable- #-}-{-# OPTIONS- -Wall- -fno-warn-name-shadowing- #-}---- | INTERNAL module is used to infer Haskell types from Java types.-module Typomatic (- runTypomatic,- typomatic,- ArgInfo (..),-- dataTName,- dataCName,- newtTName,- newtCName,- tyclTName-) where--import Language.Java.Reflect--import Control.Monad.State hiding (void)-import qualified Control.Monad.State as State-import Data.Functor.Identity-import Data.Functor ((<$>))--import Data.Generics--import qualified Data.Set as Set-import Data.Set (Set)-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.List as List--dataTName, dataCName, newtTName, newtCName, tyclTName :: String -> String--dataTName = (++ "''")-dataCName = id -- (++ "")-newtTName = (++ "'")-newtCName = (++ "'")-tyclTName = id -- (++ "")---- | This is the information which is ultimately--- gathered by the use of this module.-data ArgInfo = ArgInfo {- fSignature :: String,- fArguments :: [TVar],- fReturnType :: TVar,- fArgNames :: [String],- fJavaSignature :: String,- fJavaReturnType :: String,- fJniSignature :: String- }--tr :: Eq a => a -> a -> [a] -> [a]-tr a b (x:xs)- | a == x = b : tr a b xs- | otherwise = x : tr a b xs-tr _ _ [] = []--breakLast :: [a] -> ([a], a)-breakLast [a] = ([], a)-breakLast (a:as) =- let (init', last') = breakLast as- in (a:init', last')-breakLast _ = error "Foreign.Java.Util.breakLast: empty list"-------------------------- Type variables -------------------------data TVar = TVar String | TVars [TVar]- deriving (Eq, Ord, Show, Data, Typeable)--printTVar :: TVar -> String-printTVar var = case var of- (TVar v) -> v- (TVars vs) -> concat ["(", tail (concatMap ((' ':) . printTVar) vs), ")"]--------------------- Utilities --------------------printJniType :: JavaType -> String-printJniType t = case t of- JBoolean -> "JNI.boolean"- JChar -> "JNI.char"- JByte -> "JNI.byte"- JShort -> "JNI.short"- JInt -> "JNI.int"- JLong -> "JNI.long"- JFloat -> "JNI.float"- JDouble -> "JNI.double"- JObj n -> "JNI.object \"" ++ n ++ "\""- -- arrays are treated as objects:- JArr c -> "JNIS.object' \"[" ++ printJniRawType c ++ "\""---printJniRawType :: JavaType -> String-printJniRawType t = case t of- JBoolean -> "Z"- JChar -> "C"- JByte -> "B"- JShort -> "S"- JInt -> "I"- JLong -> "J"- JFloat -> "F"- JDouble -> "D"- JObj n -> 'L' : tr '.' '/' n ++ ";"- JArr c -> '[' : printJniRawType c---printJniSignature :: JavaMethod -> String-printJniSignature method = show name ++ " JNI.::= " ++ args ++ ret- where- name = methodName method- args = concatMap ((++ " --> ") . printJniType) (map fst $ methodParams method)- ret = maybe "JNI.void" printJniType (fst $ methodReturnType method)----typomatic :: JavaClass -> JavaMethod -> Typomatic ArgInfo-typomatic clazz method_ = do-- let className = classFullName clazz- classParams = classTypeParams clazz-- -- sanitize tyVars tied to the method by distinguishing- -- from tyVars tied to the class by adding an apostrophe- -- to the name of the tyVar if it is tied to the method.- methodTypeVars = map paramName (methodTypeParams method_)- safe var@(TyVar str)- | var `elem` methodTypeVars = TyVar (str ++ "'")- | otherwise = var- method = everywhere (mkT safe) method_-- -- the following three functions create the list of- -- argument parameters, including @this@ (if the method- -- is not static) and the return type. The return type- -- is separated later on again.- thisParam = if null classParams- then NotSoGeneric className- else Parameterized {- jgtBasetype = className,- jgtParameters = (map (TypeVarReference . paramName) classParams)- }- params = (if methodStatic method then [] else [thisParam])- ++ map snd (methodParams method)- ++ [maybe (TypeVarReference (TyVar "()"))- (const $ snd $ methodReturnType method)- (fst $ methodReturnType method)]- jtypes = (if methodStatic method then [] else [JObj className])- ++ map fst (methodParams method)-- -- turns a JavaGenericType definition into type variables.- -- The names are taken from the monad via 'newVar'.- tvar param = case jgtType param of- WildcardT -> do- name <- newVar- return $ TVar name- ParameterizedT -> do- name <- newVar- params <- mapM tvar (jgtParameters param)- return $ TVars $ TVar name : params- GenericArrayT -> do- name <- newVar- return $ TVar name- TypeVarReferenceT -> do- let name = (tyVarName (jgtName param))- return $ TVar name- NotSoGenericT -> do- name <- newVar- return $ TVar name-- -- creates a haskell signature (-> String)- signature typeVars returnVar = do- -- retrieve the context and turn each variable into a String.- contexts <- getContext >>= mapM (\(tvar, context) -> do- return $ context ++ " " ++ printTVar tvar)-- let argTypes = concatMap ((++ " -> ") . printTVar) typeVars- -- the final type is wrapped in the Java monad- returnType = "JNI.Java " ++ printTVar returnVar- -- finally assemble the conetext.- context = if null contexts then "" else- "(" ++ concat (List.intersperse ", " contexts) ++ ") => "- - -- return the full signature, consisting of the context,- -- the type of the arguments, and the return type.- return $ concat [context, argTypes, returnType]-- -- create a java signature (-> String)- javaSignature = do- let name = methodName method- args = map printJavaType $ map fst $ methodParams method- return $ name ++ "(" ++ concat (List.intersperse ", " args) ++ ")"- -- -- if this is not a static method the first argument- -- is /this/. This merely pushed the name into the list- -- of type variable names in the monad.- when (not $ methodStatic method) (pushVar "this")-- -- get type variables for all arguments, including the- -- return type (as the return type may be the same as- -- one of the argument types).- --- -- Split the result into arguments and return var again,- -- since the return variable will get special treatment- -- henceforth.- (typeVars, returnVar_) <- breakLast <$> mapM tvar params-- -- augment the return type variable, i.e. if it is not- -- a type variable at all, replace the variable name by- -- a constant reference to a specific type.- --- -- This is only the case with parameterized type variables- -- and not-so-generic ones.- returnVar <- case fst (methodReturnType method) of- Just (JObj typeName) -> case jgtType (snd $ methodReturnType method) of- ParameterizedT -> do- clazz <- getClass typeName- let (TVars (TVar _ : ts)) = returnVar_- return $ TVars (TVar (newtTName (classModName clazz)) : ts)- NotSoGenericT -> do- clazz <- getClass typeName- return $ TVar (newtTName (classModName clazz))- _ -> return returnVar_- _ -> return returnVar_-- -- Add contexts for all arguments and augment array types- let makeContext typeVar jtype = case jtype of- JObj name -> do- clazz <- getClass name- addContext typeVar $ tyclTName $ classModName clazz- return typeVar- JArr componentType -> do- addContext typeVar "JNIS.Array"- return typeVar- JBoolean -> do- addContext typeVar "JNIS.JBoolean"- return typeVar- JChar -> do- addContext typeVar "JNIS.JChar"- return typeVar- JByte -> do- addContext typeVar "JNIS.JByte"- return typeVar- JShort -> do- addContext typeVar "JNIS.JShort"- return typeVar- JInt -> do- addContext typeVar "JNIS.JInt"- return typeVar- JLong -> do- addContext typeVar "JNIS.JLong"- return typeVar- JFloat -> do- addContext typeVar "JNIS.JFloat"- return typeVar- JDouble -> do- addContext typeVar "JNIS.JDouble"- return typeVar-- -- Here makeContexts is applied (see above). In the same pass a new- -- set of typeVars (typeVars') is generated, since makeContexts- -- migth further investigate array and create type variables for- -- their component types.- typeVars' <- mapM (uncurry makeContext) (zip typeVars jtypes)-- -- Create contexts for the ultimate return type.- returnVar' <- case fst (methodReturnType method) of- Nothing -> do- let tvar = TVar "void"- addContext tvar "JNIS.VoidResult"- return tvar- Just t -> case t of- JObj _ -> do- let tvar = TVars [TVar "object", returnVar]- addContext tvar "JNIS.ObjectResult"- return tvar- JArr _ -> do- let tvar = TVar "array"- addContext tvar "JNIS.ArrayResult"- return tvar- JBoolean -> do- let tvar = TVar "boolean"- addContext tvar "JNIS.BooleanResult"- return tvar- JChar -> do- let tvar = TVar "char"- addContext tvar "JNIS.CharResult"- return tvar- JByte -> do- let tvar = TVar "byte"- addContext tvar "JNIS.ByteResult"- return tvar- JShort -> do- let tvar = TVar "short"- addContext tvar "JNIS.ShortResult"- return tvar- JInt -> do- let tvar = TVar "int"- addContext tvar "JNIS.IntResult"- return tvar- JLong -> do- let tvar = TVar "long"- addContext tvar "JNIS.LongResult"- return tvar- JFloat -> do- let tvar = TVar "float"- addContext tvar "JNIS.FloatResult"- return tvar- JDouble -> do- let tvar = TVar "double"- addContext tvar "JNIS.DoubleResult"- return tvar-- -- generate the Haskell signature (a String)- sig <- signature typeVars' returnVar'-- -- generate the Java signature (a String).- -- This is used for documentation purposed later on- -- (i.e. inserted as haddock docstring).- jsig <- javaSignature-- -- generate the names of the arguments- let argNames = (if methodStatic method then id else ("this":) . init)- $ zipWith (\_ i -> 'a' : show i) typeVars [(1 :: Integer)..]-- -- assemble and return all the calculated information- return $ ArgInfo {- fArguments = typeVars,- fReturnType = returnVar',- fArgNames = argNames,- fSignature = sig,- fJavaSignature = jsig,- fJavaReturnType = maybe "void" printJavaType (fst $ methodReturnType method),- fJniSignature = printJniSignature method- }------------------------------------------------- The following are utilities for the monad------------------------------------------------- | The state of the monad.-data TypomaticState = TypomaticState {- tVars :: [String],- tContext :: Set (TVar, String),- tParams :: [String],- tClasses :: Map String JavaClass- }---- | Retrieve the definition of a class.------ The monad has an internal store of class names--- and their definitions. See 'tClasses'.-getClass :: String -> Typomatic JavaClass-getClass name = do- state <- State.get- return ((tClasses state) Map.! name)---- | Get the current context as a list.-getContext :: Typomatic [(TVar, String)]-getContext = State.get >>= return . Set.toList . tContext---- | Add a context for a specific type variable.-addContext :: TVar -> String -> Typomatic ()-addContext tvar string = do- state <- State.get- State.put (state {tContext = ((tvar, string) `Set.insert` tContext state)})---- | Introduce a new name.------ This simply takes the next element in the infinite--- 'tVars' list and stores the tail back in the monad.-newVar :: Typomatic String-newVar = do- state <- State.get- let (v:vs) = tVars state- State.put (state { tVars = vs})- return v---- | Push a new name in the front of the available names.-pushVar :: String -> Typomatic ()-pushVar name = do- state <- State.get- State.put (state {tVars = (name : tVars state)})---- | The monad.-newtype Typomatic a = Typomatic { _runTypomatic :: StateT TypomaticState Identity a }- deriving (Monad, MonadState TypomaticState, Functor)---- | Run a computation in the monad.-runTypomatic :: Map String JavaClass -> Typomatic a -> a-runTypomatic classes =- let state = TypomaticState { -- initial state- tVars = map (('v':) . show) [(1 :: Integer)..],- tContext = Set.empty,- tParams = [],- tClasses = classes- } in fst . runIdentity . flip runStateT state . _runTypomatic----
src/Utils.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE Haskell2010+ , GeneralizedNewtypeDeriving+ , DeriveDataTypeable+ #-} {-# OPTIONS -Wall -fno-warn-missing-signatures@@ -14,23 +17,7 @@ import qualified Data.Set as Set import qualified Data.Bimap as Bimap --exhaustively :: Eq a => (a -> a) -> a -> a-exhaustively = exhaustivelyBy (==)--exhaustivelyBy :: (a -> a -> Bool) -> (a -> a) -> a -> a-exhaustivelyBy predicate func dat = case predicate dat result of- True -> result- False -> exhaustivelyBy predicate func result- where result = func dat--exhaustivelyByM :: Monad m => (a -> a -> m Bool) -> (a -> m a) -> a -> m a-exhaustivelyByM predicate func dat = do- result <- func dat- exhausted <- predicate dat result- case exhausted of- True -> return result- False -> exhaustivelyByM predicate func result+(>>>) = flip (.) intersections :: Ord a => [Set a] -> Set a intersections sets = case sets of@@ -38,6 +25,8 @@ [x] -> x (x:xs) -> foldl' Set.intersection x xs +uneither :: Either a a -> a+uneither = either id id -- Following 20 lines: Functions for managing a Bimap -- such that it works with case insensitive string.@@ -48,6 +37,7 @@ -- BimapWithGenericComparisonFunction or ...) newtype CaseInsensitiveString = CIS String+ deriving Show instance Eq CaseInsensitiveString where (CIS a) == (CIS b) = strToLower a == strToLower b@@ -60,7 +50,13 @@ xEmpty = Bimap.empty xInsert k v = Bimap.insert (CIS k) (CIS v) xMemberR k = Bimap.memberR (CIS k)-xGet m = xToString . (Bimap.!) m . CIS++xLookup :: Bimap.Bimap CaseInsensitiveString CaseInsensitiveString -> String -> Maybe String+xLookup m = maybe Nothing (Just . xToString) . (flip Bimap.lookup m) . CIS++xLookupR :: Bimap.Bimap CaseInsensitiveString CaseInsensitiveString -> String -> Maybe String+xLookupR m = maybe Nothing (Just . xToString) . (flip Bimap.lookupR m) . CIS+ xFromList = Bimap.fromList . map (\(a, b) -> (CIS a, CIS b)) xToList = map (\(a, b) -> (xToString a, xToString b)) . Bimap.toList xKeysR = map xToString . Bimap.keysR