Commit 3ea29a70 authored by ijones's avatar ijones
Browse files

integrated some changes from bringert (separate install for Hugs and GHC)

** more tests for install hugs and ghc
** test --install-prefix
** checked return codes for more operations
** broke Install targets into separate functions for GHC and Hugs
** started using pathJoin and copyFile
** still more integration to go.
parent aa169758
......@@ -46,7 +46,7 @@ module Main where
-- Import everything, since we want to test the compilation of them:
import qualified Distribution.Version as D.V (hunitTests)
import qualified Distribution.Version as D.V (hunitTests)
-- import qualified Distribution.InstalledPackageInfo(hunitTests)
import qualified Distribution.Misc as D.M (hunitTests)
import qualified Distribution.Package as D.P (hunitTests)
......@@ -57,6 +57,7 @@ import qualified Distribution.Simple.Install as D.S.I (hunitTests)
import qualified Distribution.Simple.Build as D.S.B (hunitTests)
import qualified Distribution.Simple.SrcDist as D.S.S (hunitTests)
import qualified Distribution.Simple.Utils as D.S.U (hunitTests)
import Distribution.Simple.Utils(pathJoin)
import qualified Distribution.Simple.Configure as D.S.C (hunitTests)
import qualified Distribution.Simple.Register as D.S.R (hunitTests)
......@@ -78,6 +79,23 @@ runTestTT' (TestLabel l t)
= putStrLn (label l) >> runTestTT t
runTestTT' t = runTestTT t
checkTargetDir :: FilePath
-> [String] -- ^suffixes
-> IO ()
checkTargetDir targetDir suffixes
= do doesDirectoryExist targetDir >>=
assertBool "target dir exists"
let files = [x++y |
x <- ["A", "B/A"],
y <- suffixes]
allFilesE <- sequence [doesFileExist (targetDir ++ t)
| t <- files]
sequence [assertBool ("target file missing: " ++ targetDir ++ f) e
| (e, f) <- zip allFilesE files]
return ()
tests :: [Test]
tests = [TestCase $
do setCurrentDirectory "test"
......@@ -85,30 +103,36 @@ tests = [TestCase $
when dirE1 (system "rm -r ,tmp">>return())
dirE2 <- doesDirectoryExist "dist"
when dirE2 (system "rm -r dist">>return())
-- system "ls"
system "./setup configure --prefix=,tmp"
let targetDir = ",tmp/lib/test-1.0/"
system "./setup configure --ghc --prefix=,tmp"
>>= assertEqual "configure returned error code" ExitSuccess
system "./setup build"
instRetCode <- system "./setup install --user"
doesDirectoryExist targetDir >>=
assertBool "target dir exists"
let files = "libHStest-1.0.a":[x++y |
x <- ["A", "B/A"],
y <- [".o", ".hi", ".hs"]]
allFilesE <- sequence [doesFileExist (targetDir ++ t)
| t <- files]
sequence [assertBool ("target file missing: " ++ targetDir ++ f) e
| (e, f) <- zip allFilesE files]
>>= assertEqual "build returned error code" ExitSuccess
system "./setup sdist"
>>= assertEqual "setup sdist returned error code" ExitSuccess
doesFileExist "dist/test-1.0.tgz" >>=
assertBool "sdist did not put the expected file in place"
doesFileExist "dist/src" >>=
assertEqual "dist/src exists" False
doesDirectoryExist "dist/build" >>=
assertBool "dist/build doesn't exists"
assertBool "dist/build doesn't exists",
TestCase $ -- GHC and --install-prefix (uses above config)
do let targetDir = ",tmp2"
instRetCode <- system $ "./setup install --install-prefix=" ++ targetDir
checkTargetDir ",tmp2/lib/test-1.0/" [".hi"]
doesFileExist (pathJoin [",tmp2/lib/test-1.0/", "libHStest-1.0.a"])
>>= assertBool "library doesn't exist"
assertEqual "install returned error code" ExitSuccess instRetCode,
TestCase $ -- no intsall-prefix and hugs
do system "./setup configure --hugs --prefix=,tmp"
>>= assertEqual "HUGS configure returned error code" ExitSuccess
system "./setup build"
>>= assertEqual "HUGS build returned error code" ExitSuccess
instRetCode <- system "./setup install --user"
let targetDir = ",tmp/lib/test-1.0/"
checkTargetDir targetDir [".hs"]
assertEqual "install returned error code" ExitSuccess instRetCode
]
]
main :: IO ()
main = do putStrLn "compile successful"
......
......@@ -53,7 +53,10 @@ module Distribution.Simple.Install (
import Distribution.Package (PackageDescription(..), showPackageId)
import Distribution.Simple.Configure(LocalBuildInfo(..))
import Distribution.Simple.Utils(setupMessage, moveSources,
pathSeperatorStr, mkLibName)
pathSeperatorStr, mkLibName, pathJoin,
copyFile, die
)
import Distribution.Setup (CompilerFlavor(..), Compiler(..))
import System.Cmd(system)
......@@ -61,27 +64,37 @@ import System.Cmd(system)
import HUnit (Test)
#endif
-- |FIX: for now, only works with hugs or sdist-style
-- installation... must implement for .hi files and such... how do we
-- know which files to expect?
-- |FIX: nhc isn't implemented yet.
install :: FilePath -- ^build location
-> PackageDescription -> LocalBuildInfo
-> Maybe FilePath -- ^install-prefix
-> IO ()
install buildPref pkg_descr lbi install_prefixM = do
let pref = (maybe (prefix lbi) id install_prefixM) ++
pathSeperatorStr ++ "lib" ++ pathSeperatorStr ++ (showPackageId $ package pkg_descr)
setupMessage "Installing" pkg_descr
-- FIX: For hugs only
moveSources "" pref (allModules pkg_descr) (mainModules pkg_descr) ["lhs", "hs"]
-- FIX: for GHC and NHC only
moveSources buildPref pref (allModules pkg_descr) (mainModules pkg_descr) ["hi"]
moveSources buildPref pref (allModules pkg_descr) (mainModules pkg_descr) ["o"]
system $ "cp " ++ mkLibName buildPref (showPackageId (package pkg_descr))
++ " " ++ mkLibName pref (showPackageId (package pkg_descr))
let pref = pathJoin [(maybe (prefix lbi) id install_prefixM), "lib",
(showPackageId $ package pkg_descr)]
setupMessage ("Installing: " ++ pref) pkg_descr
case compilerFlavor (compiler lbi) of
GHC -> installGHC pref buildPref pkg_descr
Hugs -> installHugs pref pkg_descr
_ -> die ("only installing with GHC or Hugs is implemented")
return ()
-- register step should be performed by caller.
-- |Install for ghc, .hi and .a
installGHC :: FilePath -- ^install location
-> FilePath -- ^Build location
-> PackageDescription -> IO ()
installGHC pref buildPref pkg_descr
= do moveSources buildPref pref (allModules pkg_descr) (mainModules pkg_descr) ["hi"]
copyFile (mkLibName buildPref (showPackageId (package pkg_descr)))
(mkLibName pref (showPackageId (package pkg_descr)))
-- |Install for hugs, .lhs and .hs
installHugs :: FilePath -- ^Install location
-> PackageDescription -> IO ()
installHugs pref pkg_descr
= moveSources "" pref (allModules pkg_descr) (mainModules pkg_descr) ["lhs", "hs"]
-- -----------------------------------------------------------------------------
-- Installation policies
......
......@@ -57,6 +57,8 @@ module Distribution.Simple.Utils (
hunitTests,
createIfNotExists,
mkLibName,
copyFile,
pathJoin
) where
import Distribution.Package (PackageDescription(..), showPackageId)
......@@ -298,6 +300,16 @@ mkLibName :: FilePath -- ^file Prefix
-> String
mkLibName pref lib = pref ++ pathSeperatorStr ++ "libHS" ++ lib ++ ".a"
-- | Create a path from a list of path elements
pathJoin :: [String] -> FilePath
pathJoin = concat . intersperse pathSeperatorStr
-- FIX: does not preserve dates, does not set permissions
copyFile :: FilePath -> FilePath -> IO ()
copyFile src dest
| dest == src = fail "copyFile: source and destination are the same file"
| otherwise = readFile src >>= writeFile dest
-- ------------------------------------------------------------
-- * Testing
-- ------------------------------------------------------------
......
* Quick
** fix "Seperator" - use pathJoin
** use copyFile instead of "cp"
* misc
** setup test suite to run on --push?
** Possibly create a (native?) zib library?
** port code to windows
** test / port code for Hugs and nhc
** ./Setup.lhs build for nhc
** nhc-pkg (see old package manager code)
** hugs-pkg
** better command-line parsing interface
** ./Setup.lhs bdist
* testing
** count errors and output.
** setup test suite to run on --push?
** redirect non-hunit outputs to a file?
** test / port code for Hugs and nhc
* Code
** FIX: does it try to register when we have "install --inst-prefix"?
(write test case)
** FIX: install currently moves .hs, .hi, and .o files for any target.
make it do the right thing for hugs (just move .hs) and {g,n}hc
(move .hi and .o)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment