@@ -37,66 +37,132 @@ import System.Process
3737
3838-----------------------------------------------------------------------
3939-- Main function
40−
4140codegenJava :: [(Name, SExp)] -> -- initialization of globals
42− [(Name, SDecl)] ->
41+ [(Name, SDecl)] -> -- decls
4342 FilePath -> -- output file name
4443 [String] -> -- headers
4544 [String] -> -- libs
4645 OutputType ->
4746 IO ()
48−codegenJava globalInit defs out hdrs libs exec = do
49− withTempdir (takeBaseName out) $ \ tmpDir -> do
50− let srcdir = tmpDir </> "src" </> "main" </> "java"
51− createDirectoryIfMissing True srcdir
52− let (Ident clsName) = either error id (mkClassName out)
53− let outjava = srcdir </> clsName <.> "java"
54− let jout = either error
47+codegenJava globalInit defs out hdrs libs exec =
48+ withTgtDir exec out (codegenJava' exec)
49+ where
50+ codegenJava' :: OutputType -> FilePath -> IO ()
51+ codegenJava' Raw tgtDir = do
52+ srcDir <- prepareSrcDir exec tgtDir
53+ generateJavaFile globalInit defs hdrs srcDir out
54+ codegenJava' MavenProject tgtDir = do
55+ codegenJava' Raw tgtDir
56+ generatePom tgtDir out libs
57+ codegenJava' Object tgtDir = do
58+ codegenJava' MavenProject tgtDir
59+ invokeMvn tgtDir "compile"
60+ copyClassFiles tgtDir out
61+ cleanUpTmp tgtDir
62+ codegenJava' _ tgtDir = do
63+ codegenJava' MavenProject tgtDir
64+ invokeMvn tgtDir "package";
65+ copyJar tgtDir out
66+ makeJarExecutable out
67+ cleanUpTmp tgtDir
68+
69+-----------------------------------------------------------------------
70+-- Compiler IO
71+
72+withTgtDir :: OutputType -> FilePath -> (FilePath -> IO ()) -> IO ()
73+withTgtDir Raw out action = action (dropFileName out)
74+withTgtDir MavenProject out action = createDirectoryIfMissing False out >> action out
75+withTgtDir _ out action = withTempdir (takeBaseName out) action
76+
77+prepareSrcDir :: OutputType -> FilePath -> IO FilePath
78+prepareSrcDir Raw tgtDir = return tgtDir
79+prepareSrcDir _ tgtDir = do
80+ let srcDir = (tgtDir </> "src" </> "main" </> "java")
81+ createDirectoryIfMissing True srcDir
82+ return srcDir
83+
84+javaFileName :: FilePath -> FilePath -> FilePath
85+javaFileName srcDir out =
86+ either error (\ (Ident clsName) -> srcDir </> clsName <.> "java") (mkClassName out)
87+
88+generateJavaFile :: [(Name, SExp)] -> -- initialization of globals
89+ [(Name, SDecl)] -> -- definitions
90+ [String] -> -- headers
91+ FilePath -> -- Source dir
92+ FilePath -> -- output target
93+ IO ()
94+generateJavaFile globalInit defs hdrs srcDir out = do
95+ let code = either error
5596 (prettyPrint)-- flatIndent . prettyPrint)
5697 (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv)
57− writeFile outjava jout
58− if (exec == Raw)
59− then copyFile outjava (takeDirectory out </> clsName <.> "java")
60− else do
61− execPom <- getExecutablePom
62− execPomTemplate <- TIO.readFile execPom
63− let execPom = T.replace (T.pack "$MAIN-CLASS$")
64− (T.pack clsName)
65− (T.replace (T.pack "$ARTIFACT-NAME$")
66− (T.pack $ takeBaseName out)
67− (T.replace (T.pack "$DEPENDENCIES$")
68− (mkPomDependencies libs)
69− execPomTemplate
70− )
71− )
72− TIO.writeFile (tmpDir </> "pom.xml") execPom
73− mvnCmd <- getMvn
74− let args = ["-f", (tmpDir </> "pom.xml")]
75− (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["compile"]) ""
76− when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout)
77− if (exec == Object)
78− then do
79− classFiles <-
80− map (\ clsFile -> tmpDir </> "target" </> "classes" </> clsFile)
98+ writeFile (javaFileName srcDir out) code
99+
100+pomFileName :: FilePath -> FilePath
101+pomFileName tgtDir = tgtDir </> "pom.xml"
102+
103+generatePom :: FilePath -> -- tgt dir
104+ FilePath -> -- output target
105+ [String] -> -- libs
106+ IO ()
107+generatePom tgtDir out libs = do
108+ execPom <- getExecutablePom
109+ execPomTemplate <- TIO.readFile execPom
110+ let (Ident clsName) = either error id (mkClassName out)
111+ let execPom = T.replace (T.pack "$MAIN-CLASS$")
112+ (T.pack clsName)
113+ (T.replace (T.pack "$ARTIFACT-NAME$")
114+ (T.pack $ takeBaseName out)
115+ (T.replace (T.pack "$DEPENDENCIES$")
116+ (mkPomDependencies libs)
117+ execPomTemplate
118+ )
119+ )
120+ TIO.writeFile (pomFileName tgtDir) execPom
121+
122+invokeMvn :: FilePath -> String -> IO ()
123+invokeMvn tgtDir command = do
124+ mvnCmd <- getMvn
125+ let args = ["-f", pomFileName tgtDir]
126+ (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ [command]) ""
127+ when (exit /= ExitSuccess) $
128+ error ("FAILURE: " ++ mvnCmd ++ " " ++ command ++ "\n" ++ err ++ mvout)
129+
130+classFileDir :: FilePath -> FilePath
131+classFileDir tgtDir = tgtDir </> "target" </> "classes"
132+
133+copyClassFiles :: FilePath -> FilePath -> IO ()
134+copyClassFiles tgtDir out = do
135+ classFiles <- map (\ clsFile -> classFileDir tgtDir </> clsFile)
81136 . filter ((".class" ==) . takeExtension)
82− <$> getDirectoryContents (tmpDir </> "target" </> "classes")
83− mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile))
84− classFiles
85− else do
86− (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) ""
87− when (exit /= ExitSuccess) (error ("FAILURE: " ++ mvnCmd ++ " package\n" ++ err ++ mvout))
88− copyFile (tmpDir </> "target" </> (takeBaseName out) <.> "jar") out
89− handle <- openBinaryFile out ReadMode
90− contents <- TIO.hGetContents handle
91− hClose handle
92− handle <- openBinaryFile out WriteMode
93− TIO.hPutStr handle (T.append (T.pack jarHeader) contents)
94− hFlush handle
95− hClose handle
96− perms <- getPermissions out
97− setPermissions out (setOwnerExecutable True perms)
98− readProcess mvnCmd (args ++ ["clean"]) ""
99− removeFile (tmpDir </> "pom.xml")
137+ <$> getDirectoryContents (classFileDir tgtDir)
138+ mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile)) classFiles
139+
140+jarFileName :: FilePath -> FilePath -> FilePath
141+jarFileName tgtDir out = tgtDir </> "target" </> (takeBaseName out) <.> "jar"
142+
143+copyJar :: FilePath -> FilePath -> IO ()
144+copyJar tgtDir out =
145+ copyFile (jarFileName tgtDir out) out
146+
147+makeJarExecutable :: FilePath -> IO ()
148+makeJarExecutable out = do
149+ handle <- openBinaryFile out ReadMode
150+ contents <- TIO.hGetContents handle
151+ hClose handle
152+ handle <- openBinaryFile out WriteMode
153+ TIO.hPutStr handle (T.append (T.pack jarHeader) contents)
154+ hFlush handle
155+ hClose handle
156+ perms <- getPermissions out
157+ setPermissions out (setOwnerExecutable True perms)
158+
159+removePom :: FilePath -> IO ()
160+removePom tgtDir = removeFile (pomFileName tgtDir)
161+
162+cleanUpTmp :: FilePath -> IO ()
163+cleanUpTmp tgtDir = do
164+ invokeMvn tgtDir "clean"
165+ removePom tgtDir
100166
101167-----------------------------------------------------------------------
102168-- Jar and Pom infrastructure