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

Distribution/Extension.hs

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

Distribution/Simple.hs

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

Distribution/Simple/Install.hs

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

Distribution/Simple/Register.hs

@@ -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)]
 
 
 -- ------------------------------------------------------------