Commit e6214fc9 authored by ijones's avatar ijones
Browse files

from Ross and CVS

First cut at installHugs.  The treatment of executables is still incomplete.
simplistic register/unregister for Hugs:
  
  * register copies the installed package decsription into the packages dir
  
  * unregister uninstalls the package
Hugs supports FFI without extra flags
parent af6fc070
......@@ -172,6 +172,7 @@ extensionsToHugsFlag l
extensionToHugsFlag RestrictedTypeSynonyms = Right "-98"
extensionToHugsFlag FlexibleContexts = Right "-98"
extensionToHugsFlag FlexibleInstances = Right "-98"
extensionToHugsFlag ForeignFunctionInterface = Right ""
extensionToHugsFlag EmptyDataDecls = Right ""
extensionToHugsFlag e = Left e
......
......@@ -49,7 +49,7 @@ module Distribution.Simple (
orLaterVersion, orEarlierVersion, betweenVersionsInclusive,
Extension(..), Dependency(..),
defaultMain, defaultMainNoRead, defaultMainWithHooks,
UserHooks (..), defaultUserHooks, hookedPackageDesc,
UserHooks (..), emptyUserHooks, defaultUserHooks, hookedPackageDesc,
#ifdef DEBUG
simpleHunitTests
#endif
......
......@@ -45,6 +45,8 @@ module Distribution.Simple.Install (
install,
mkBinDir,
mkLibDir,
hugsPackageDir,
hugsProgramsDir,
#ifdef DEBUG
hunitTests
#endif
......@@ -56,19 +58,20 @@ module Distribution.Simple.Install (
import Distribution.PackageDescription (
PackageDescription(..), BuildInfo(..), Executable(..),
setupMessage, hasLibs, withLib, libModules)
import Distribution.Package (showPackageId)
setupMessage, hasLibs, withLib, libModules, exeModules, biModules)
import Distribution.Package (showPackageId, pkgName)
import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..))
import Distribution.Simple.Utils(moveSources, rawSystemExit,
mkLibName,
mkLibName, removeFileRecursive,
die, createIfNotExists
)
import Distribution.Setup (CompilerFlavor(..), Compiler(..))
import Control.Monad(when)
import Control.Monad(when, unless)
import Data.Maybe(maybeToList, fromMaybe)
import Distribution.Compat.Directory(copyFile)
import Distribution.Compat.FilePath(joinFileName)
import Distribution.Compat.FilePath(joinFileName, dllExtension)
import System.IO.Error(try)
#ifdef DEBUG
import HUnit (Test)
......@@ -87,13 +90,7 @@ install pkg_descr lbi install_prefixM = do
case compilerFlavor (compiler lbi) of
GHC -> do when (hasLibs pkg_descr) (installLibGHC libPref buildPref pkg_descr)
installExeGhc binPref buildPref pkg_descr
Hugs -> do withLib pkg_descr (\buildInfo@BuildInfo{hsSourceDir=srcDir} ->
do let targetDir = buildPref `joinFileName` srcDir
let args = targetDir
: (maybeToList install_prefixM)
let hugsPkg = compilerPkgTool $ compiler $ lbi
rawSystemExit hugsPkg args)
-- FIX (HUGS): Install executables, still needs work in build step
Hugs -> installHugs libPref binPref buildPref pkg_descr
_ -> die ("only installing with GHC or Hugs is implemented")
return ()
-- register step should be performed by caller.
......@@ -117,12 +114,45 @@ installLibGHC pref buildPref pd@PackageDescription{library=Just l,
copyFile (mkLibName buildPref (showPackageId p))
(mkLibName pref (showPackageId p))
-- |Install for hugs, .lhs and .hs
installHugs :: FilePath -- ^Install location
-> FilePath -- ^Build location
-> PackageDescription -> IO ()
installHugs pref buildPref pd@PackageDescription{library=Just l}
= moveSources (buildPref `joinFileName` (hsSourceDir l)) pref (libModules pd) ["lhs", "hs"]
-- |Install for Hugs
installHugs
:: FilePath -- ^Library install location
-> FilePath -- ^Executable install location
-> FilePath -- ^Build location
-> PackageDescription
-> IO ()
installHugs libPref binPref buildPref pkg_descr = do
let hugsDir = libPref `joinFileName` "hugs"
let pkg_name = pkgName (package pkg_descr)
withLib pkg_descr $ \ libInfo -> do
let pkgDir = hugsDir `joinFileName` "packages"
`joinFileName` pkg_name
try $ removeFileRecursive pkgDir
moveSources buildPref pkgDir (biModules libInfo) hugsInstallSuffixes
unless (null (executables pkg_descr)) $ do
let progBuildDir = buildPref `joinFileName` "programs"
let progInstallDir = hugsDir `joinFileName` "programs"
`joinFileName` pkg_name
try $ removeFileRecursive progInstallDir
moveSources progBuildDir progInstallDir
(exeModules pkg_descr) hugsInstallSuffixes
flip mapM_ (executables pkg_descr) $ \ Executable {modulePath=e} ->
copyFile (progBuildDir `joinFileName` e)
(progInstallDir `joinFileName` e)
-- FIX (HUGS): Install executables, still needs work (in build step?)
hugsInstallSuffixes :: [String]
hugsInstallSuffixes = ["hs", "lhs", drop 1 dllExtension]
hugsPackageDir :: PackageDescription -> LocalBuildInfo -> FilePath
hugsPackageDir pkg_descr lbi =
prefix lbi `joinFileName` "lib" `joinFileName` "hugs"
`joinFileName` "packages" `joinFileName` pkgName (package pkg_descr)
hugsProgramsDir :: PackageDescription -> LocalBuildInfo -> FilePath
hugsProgramsDir pkg_descr lbi =
prefix lbi `joinFileName` "lib" `joinFileName` "hugs"
`joinFileName` "programs" `joinFileName` pkgName (package pkg_descr)
-- -----------------------------------------------------------------------------
-- Installation policies
......
......@@ -65,10 +65,13 @@ import Distribution.InstalledPackageInfo
(InstalledPackageInfo, showInstalledPackageInfo,
emptyInstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.Simple.Utils (rawSystemExit, die)
import Distribution.Simple.Utils (rawSystemExit, die, removeFileRecursive)
import Distribution.Simple.Install (hugsPackageDir, hugsProgramsDir)
import Distribution.Simple.GHCPackageConfig (mkGHCPackageConfig, showGHCPackageConfig)
import qualified Distribution.Simple.GHCPackageConfig
as GHC (localPackageConfig, canWriteLocalPackageConfig, maybeCreateLocalPackageConfig)
import Distribution.Compat.Directory (copyFile)
import Distribution.Compat.FilePath (joinFileName)
import System.Directory(doesFileExist, removeFile)
import System.IO (try)
......@@ -90,15 +93,14 @@ import HUnit (Test)
register :: PackageDescription -> LocalBuildInfo
-> Bool -- ^Install in the user's database?
-> IO ()
register pkg_descr lbi userInst = do
setupMessage "Registering" pkg_descr
if isNothing (library pkg_descr)
then do setupMessage "No package to register" pkg_descr
return ()
else do
case compilerFlavor (compiler lbi) of
GHC -> do
register pkg_descr lbi userInst
| isNothing (library pkg_descr) = do
setupMessage "No package to register" pkg_descr
return ()
| otherwise = do
setupMessage "Registering" pkg_descr
case compilerFlavor (compiler lbi) of
GHC -> do
let ghc_63_plus = compilerVersion (compiler lbi) >= Version [6,3] []
config_flags <-
......@@ -125,9 +127,12 @@ register pkg_descr lbi userInst = do
(["--auto-ghci-libs"]
++ register_flags
++ config_flags)
-- FIX (HUGS):
Hugs -> setupMessage "Warning: Hugs has no packaging tool\nLibrary files will just be moved into place." pkg_descr
_ -> die ("only registering with GHC is implemented")
-- FIX (HUGS):
Hugs -> do
let
copyFile installedPkgConfigFile
(hugsPackageDir pkg_descr lbi `joinFileName` "package.conf")
_ -> die ("only registering with GHC is implemented")
userPkgConfErr local_conf =
die ("--user flag passed, but cannot write to local package config: "
......@@ -137,17 +142,11 @@ userPkgConfErr local_conf =
writeInstalledConfig :: PackageDescription -> LocalBuildInfo -> IO ()
writeInstalledConfig pkg_descr lbi = do
let hc = compiler lbi
case compilerFlavor hc of
GHC ->
let pkg_config
| compilerVersion hc >= Version [6,3] []
= showInstalledPackageInfo (mkInstalledPackageInfo pkg_descr lbi)
| otherwise
= showGHCPackageConfig (mkGHCPackageConfig pkg_descr lbi)
in
writeFile installedPkgConfigFile ( pkg_config)
Hugs -> return ()
_ -> die ("only registering with GHC is implemented")
let pkg_config = case compilerFlavor hc of
GHC | compilerVersion hc < Version [6,3] [] ->
showGHCPackageConfig (mkGHCPackageConfig pkg_descr lbi)
_ -> showInstalledPackageInfo (mkInstalledPackageInfo pkg_descr lbi)
writeFile installedPkgConfigFile pkg_config
removeInstalledConfig :: IO ()
removeInstalledConfig = try (removeFile installedPkgConfigFile) >> return ()
......@@ -203,11 +202,17 @@ unregister :: PackageDescription -> LocalBuildInfo -> IO ()
unregister pkg_descr lbi = do
setupMessage "Unregistering" pkg_descr
when (compilerFlavor (compiler lbi) /= GHC) $
die ("only unregistering with GHC is implemented")
case compilerFlavor (compiler lbi) of
GHC ->
rawSystemExit (compilerPkgTool (compiler lbi))
["--remove-package=" ++ pkgName (package pkg_descr)]
Hugs -> do
try $ removeFileRecursive (hugsPackageDir pkg_descr lbi)
try $ removeFileRecursive (hugsProgramsDir pkg_descr lbi)
return ()
_ ->
die ("only unregistering with GHC and Hugs is implemented")
rawSystemExit (compilerPkgTool (compiler lbi))
["--remove-package=" ++ pkgName (package pkg_descr)]
-- ------------------------------------------------------------
......
Markdown is supported
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