java-bridge-0.20130606.3: j2hs/Java2Haskell.hss
{-# LANGUAGE Haskell2010
#-}
{-# OPTIONS
-Wall
-fno-warn-missing-signatures
-fno-warn-name-shadowing
#-}
{- | The @j2hs@ command - create Haskell bindings for Java classes.
-}
module Java2Haskell where
import Prelude hiding (print)
import Options
--import Common
import Foreign.Java
import Foreign.Java.Bindings
import Foreign.Java.Bindings.JavaTypes
import Foreign.Java.Utils
import Foreign.Java.IO
import Data.NamedRecord
import qualified Data.List as L
import Data.Strings
import Data.Generics
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.MultiMap as MultiMap
import qualified Data.Bimap as Bimap
import Control.Monad
import System.Directory
import System.FilePath
import System.IO hiding (print)
import System.Exit
-- Following 20 lines: Functions for managing a Bimap
-- such that it works with case insensitive string.
--
-- TODO: Factor this out `plus` use the case-insensitive package.
-- Those functions x... should be made into their own
-- datatype (Something like CISBimap or
-- BimapWithGenericComparisonFunction or ...)
newtype CaseInsensitiveString = CIS String
instance Eq CaseInsensitiveString where
(CIS a) == (CIS b) = strToLower a == strToLower b
instance Ord CaseInsensitiveString where
(CIS a) <= (CIS b) = strToLower a <= strToLower b
xToString (CIS s) = s
xEmpty = Bimap.empty
xInsert k v = Bimap.insert (CIS k) (CIS v)
xMemberR k = Bimap.memberR (CIS k)
xGet m = xToString . (Bimap.!) 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
xKeys = map xToString . Bimap.keys
xSize = Bimap.size
-- end todo
ifVerbose opts = when (opts `get` optVerbose) . liftIO . putStr
j2hs :: Options -> [String] -> IO ()
j2hs opts args = do
classpath <- mapM canonicalizePath $ opts `get` optClasspath
targetDir <- return (opts `get` optTargetDirectory)
let classpath' = concat $ L.intersperse ":" classpath
indent = (" " ++)
ifVerbose opts """
Classpath:
#{concatMap (\x -> " " ++ x ++ "\n") (classpath)}"""
print "Initializing JVM..."
initJava ["""-Djava.class.path=#{classpath'}"""]
println " Done."
unless (null args) $ runJava $ do
io $ do
ifVerbose opts """
Target Directory:
#{targetDir}
"""
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 <- findJavaClasses (opts `get` optSearchDepth) args
println """ #{show $ length classes} found."""
ifVerbose opts $
unlines (map indent classes)
-- Calculate the Haskell module names for packages and classes
let packages = Set.toList $ Set.fromList
$ map (maybe "" id . takePackageName) classes
-- temporary class names
classModules_ = foldr (uncurry g) xEmpty $ map f classes
where f x = (x, makeClassModuleName x)
g clazzName modName all = xInsert clazzName newName all
where newName = head $ dropWhile (`xMemberR` all)
$ iterate (++ "_") modName
-- package names.
-- This func keeps in mind that package names must not clash with class names.
packageModules = foldr (uncurry g) xEmpty $ map f packages
where f x = (x, makePackageModuleName x)
g pkgName modName all = xInsert pkgName newName all
where newName = head $ dropWhile (\n -> n `xMemberR` classModules_
|| n `xMemberR` all)
$ iterate (++ "Package") modName
-- 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,
-- thus all classes inside the package have their full name changed too.
classModules = Map.fromList $ map f $ xToList classModules_
where f (clazzName, moduleName)
= (clazzName, joinClassName (newPackageName, classModuleName))
where classModuleName = takeClassName moduleName
packageName = maybe "" id $ takePackageName clazzName
newPackageName = packageModules `xGet` packageName
-- A mapping form packages to classes
classesByPackage = MultiMap.fromList
$ map (\clazz -> (fst $ splitClassName clazz, clazz)) classes
-- A list of all modules
allModules = xKeysR packageModules ++ Map.elems classModules
-- The list of hidden modules
hiddenModules = map (++ "__") $ Map.elems classModules
-- Gather information about classes via Reflection
print """Gathering refection information..."""
let classNames = Map.keys classModules
updName name clazz = (name, clazz { classModName = classModules Map.! name })
classInfo <- Map.fromList `fmap` map (uncurry updName)
`fmap` zip classNames
`fmap` everywhere (mkT (\(TyVar v) -> TyVar ('_':v)))
`fmap` reflectJavaClasses classNames
println " Done."
when (opts `get` optOnlyReflect) $ io $ do
mapM_ println $ Map.elems classInfo
exitSuccess
println """Generating modules for #{show $ Map.size classModules} classes in \
#{show $ xSize packageModules} packages..."""
-- 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)
-- 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
hClose file
-- 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
io $ do
-- Create the Haskell module file for the Java class.
file <- openFile (fileName ++ ".hs") WriteMode
hPutStrLn file $ printJavaClassModule clazz clazzMod classInfo
hClose file
-- Create the *hidden* Haskell module file for the Java class.
file <- openFile (fileName ++ "__.hs") WriteMode
hPutStrLn file $ printJavaClassModule' clazz clazzMod classInfo
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
return ()