j2hs-0.99: src/Java2Haskell.hss

{-# LANGUAGE Haskell2010
 #-}
{-# OPTIONS
    -Wall
    -fno-warn-name-shadowing
 #-}

{- | The @j2hs@ command - create Haskell bindings for Java classes.
    
-}
module Java2Haskell where

import Prelude hiding (print)

import Options
import Utils
import Types
import Segments
import CodeGen.Class
import CodeGen.JavaBindings

import Foreign.Java
import Foreign.Java.IO

import Language.Java.Reflect

import Data.NamedRecord
import qualified Data.List as L
import Data.Strings

import Data.Generics

import Data.Map (Map)
import MultiMap (MultiMap)
import qualified Data.Map as Map
import qualified Data.Set as Set
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
    -> String
    -> m ()
ifVerbose opts = when (opts `get` optVerbose) . liftIO . putStr

-- | Invoked by Main.main, the core functionality
j2hs
    :: Options
    -> [String]
    -> IO ()
j2hs opts args = do

    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 Just <$> canonicalizePath (opts `get` optLoadReflectDump)

    opts <- augmentEnvironment

    let classpath = opts `get` optClasspath
        classpath' = concat $ L.intersperse ":" classpath

    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:
                  #{opts `get` optTargetDirectory}
                """
            
        ifVerbose opts """
            Looking for Java classes:
            #{concatMap (\x -> "  " ++ x ++ "\n") args}"""

        classInfo <- gatherClassInfo opts reflectDump args

        when (opts `get` optOnlyReflect) $ io $ do
            mapM_ println $ Map.elems classInfo
            exitSuccess

        -- Calculate the Haskell module names for packages and classes
        let classes = Map.keys classInfo

            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

            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,
            -- thus all classes inside the package have their full name changed too.
            classModules :: Map String String
            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 = bimapCheckedLookup packageModules packageName

            -- A mapping from packages to classes
            classesByPackage :: MultiMap String String
            classesByPackage = MultiMap.fromList
                             $ map (\clazz -> (fst $ splitClassName clazz, clazz)) classes

        -- Find a suitable segmentation
        rankedClusters <- findClassClusters classInfo

        let segmentSize = min (fromIntegral (opts `get` optSegmentSize)) (Map.size classInfo)
            segments = segment3 segmentSize rankedClusters
            lengths = concat $ L.intersperse ", " $ map (show . length) segments

        println """Identified #{show $ length segments} segments of lengths (#{lengths})."""

        -- 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
        }

        -- Create the code files.
        let pName = opts `get` optProjectName
            pVersion = opts `get` optProjectVersion
            mkDeps = map (\i -> pName ++ "-part" ++ show i ++ " == " ++ pVersion)

        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 options set) from a dump file.
gatherClassInfo
    :: Options
    -> Maybe FilePath
    -> [String]
    -> Java (Map String JavaClass)
gatherClassInfo opts reflectDump classNames = do

    reflectClasses <- getReflectClasses

    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 file = io $ Strict.readFile file >>= return . read
            
    classInfo <- maybe getClassInfo (\f -> print " (from dump)" >> readClassInfo f) reflectDump
    println """ Done (found #{show $ Map.size classInfo} classes)."""

    unless (null (opts `get` optSaveReflectDump)) $ io $ do
        file <- openFile (opts `get` optSaveReflectDump) WriteMode
        print """Saving dump of reflection info..."""
        hPutStr file (show classInfo)
        println " Done."
        hClose file

    return classInfo

-- This actually creates the Haskell module files for packages
generatePackageModules
    :: Options
    -> ClassInfo
    -> [String]
    -> Java ()
generatePackageModules opts info packages = do

    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_ packages $ \packageName -> do
        let packageMod = info `packageModName` packageName
            dirName = strJoin [pathSeparator] (strSplitAll "." packageMod)

        -- Create the directory for the package
        io $ do 
            createDirectoryIfMissing True dirName

            -- Create the Haskell module file for the Java package
            file <- openFile (dirName ++ ".hs") WriteMode
            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_ 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
            code <- gen info $ javaClassModule className
            hPutStrLn file code
            hClose file

            -- Create the interface Haskell module file for the Java class.
            file <- openFile (fileName ++ "__.hs") WriteMode
            code <- gen info $ javaClassModule' className
            hPutStrLn file code
            hClose file

    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