{-# OPTIONS -fffi #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Configure
-- Copyright   :  Isaac Jones 2003-2004
-- 
-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>
-- Stability   :  alpha
-- Portability :  GHC
--
-- Explanation: Perform the \"@.\/setup configure@\" action.
-- Outputs the @.setup-config@ file.

{- All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

module Distribution.Simple.Configure (writePersistBuildConfig,
                                      getPersistBuildConfig,
                                      LocalBuildInfo(..),
 			  	      configure,
                                      localBuildInfoFile,
                                      findProgram,

                                     )
    where

import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
import Distribution.Simple.Register (removeInstalledConfig)
import Distribution.Extension(extensionsToGHCFlag,
                         extensionsToNHCFlag, extensionsToHugsFlag)
import Distribution.Setup(ConfigFlags(..),CompilerFlavor(..), Compiler(..))
import Distribution.Package (PackageIdentifier(..), showPackageId, 
			     parsePackageId)
import Distribution.PackageDescription(
 	PackageDescription(..), Library(..),
	BuildInfo(..), Executable(..), setupMessage)
import Distribution.Simple.Utils (die, withTempFile,maybeExit)
import Distribution.Version (Version(..), Dependency(..), VersionRange(ThisVersion),
			     parseVersion, showVersion, withinRange,
			     showVersionRange)

import Data.List (intersperse, nub, maximumBy)
import Data.Char (isSpace)
import Data.Maybe(fromMaybe)
import System.Directory
import Distribution.Compat.FilePath (splitFilePath, joinFileName, joinFileExt)
import System.Cmd		( system )
import System.Exit		( ExitCode(..) )
import Control.Monad		( when, unless )
import Distribution.Compat.ReadP
import Distribution.Compat.Directory (findExecutable)

import Control.Exception	( catch, evaluate )

import Data.Char (isDigit)
import Prelude hiding (catch)

getPersistBuildConfig :: IO LocalBuildInfo
getPersistBuildConfig = do
  e <- doesFileExist localBuildInfoFile
  let dieMsg = "error reading " ++ localBuildInfoFile ++ "; run \"setup configure\" command?\n"
  when (not e) (die dieMsg)
  str <- readFile localBuildInfoFile
  let bi = read str

  evaluate bi `catch` \_ -> 
	die dieMsg

  return bi

writePersistBuildConfig :: LocalBuildInfo -> IO ()
writePersistBuildConfig lbi = do
  writeFile localBuildInfoFile (show lbi)

localBuildInfoFile :: FilePath
localBuildInfoFile = "./.setup-config"

-- -----------------------------------------------------------------------------
-- * Configuration
-- -----------------------------------------------------------------------------

configure :: PackageDescription -> ConfigFlags -> IO LocalBuildInfo
configure pkg_descr cfg
  = do
	setupMessage "Configuring" pkg_descr
	removeInstalledConfig
        let lib = library pkg_descr
	-- prefix
	defPrefix <- system_default_prefix pkg_descr
        let pref = fromMaybe defPrefix (configPrefix cfg)
	-- detect compiler
	comp@(Compiler f' ver p' pkg) <- configCompiler cfg
        -- check extensions
        let extlist = nub $ maybe [] (extensions . libBuildInfo) lib ++
                      concat [ extensions exeBi | Executable _ _ exeBi <- executables pkg_descr ]
        let exts = case f' of
                     GHC  -> fst $ extensionsToGHCFlag extlist
                     NHC  -> fst $ extensionsToNHCFlag extlist
                     Hugs -> fst $ extensionsToHugsFlag extlist
                     _    -> [] -- Hmm.
        unless (null exts) $ putStrLn $ -- Just warn, FIXME: Should this be an error?
            "Warning: " ++ show f' ++ " does not support the following extensions:\n " ++
            concat (intersperse ", " (map show exts))
        haddock <- findProgram "haddock" (configHaddock cfg)
        happy   <- findProgram "happy"   (configHappy cfg)
        alex    <- findProgram "alex"    (configAlex cfg)
        hsc2hs  <- findProgram "hsc2hs"  (configHsc2hs cfg)
        cpphs   <- findProgram "cpphs"   (configCpphs cfg)
        -- FIXME: maybe this should only be printed when verbose?
        message $ "Using install prefix: " ++ pref
        message $ "Using compiler: " ++ p'
        message $ "Compiler flavor: " ++ (show f')
        message $ "Compiler version: " ++ showVersion ver
        message $ "Using package tool: " ++ pkg
        reportProgram "haddock" haddock
        reportProgram "happy"   happy
        reportProgram "alex"    alex
        reportProgram "hsc2hs"  hsc2hs
        reportProgram "cpphs"   cpphs
        -- FIXME: currently only GHC has hc-pkg
        dep_pkgs <- if f' == GHC && ver >= Version [6,3] [] then do
            ipkgs <-  getInstalledPackages comp cfg
	    mapM (configDependency ipkgs) (buildDepends pkg_descr)
          else return $ map setDepByVersion (buildDepends pkg_descr)
	return LocalBuildInfo{prefix=pref, compiler=comp,
			      buildDir="dist" `joinFileName` "build",
                              packageDeps=dep_pkgs,
                              withHaddock=haddock,
                              withHappy=happy, withAlex=alex,
                              withHsc2hs=hsc2hs, withCpphs=cpphs
                             }

-- |Converts build dependencies to a versioned dependency.  only sets
-- version information for exact versioned dependencies.
setDepByVersion :: Dependency -> PackageIdentifier

-- if they specify the exact version, use that:
setDepByVersion (Dependency s (ThisVersion v)) = PackageIdentifier s v

-- otherwise, just set it to empty
setDepByVersion (Dependency s _) = PackageIdentifier s (Version [] [])

-- |Return the explicit path if given, otherwise look for the program
-- name in the path.
findProgram
    :: String              -- ^ program name
    -> Maybe FilePath      -- ^ optional explicit path
    -> IO (Maybe FilePath)
findProgram name Nothing = findExecutable name
findProgram _ p = return p

reportProgram :: String -> Maybe FilePath -> IO ()
reportProgram name Nothing = message ("No " ++ name ++ " found")
reportProgram name (Just p) = message ("Using " ++ name ++ ": " ++ p)

-- | Test for a package dependency and record the version we have installed.
configDependency :: [PackageIdentifier] -> Dependency -> IO PackageIdentifier
configDependency ps (Dependency pkgname vrange) = do
  let
	ok p = pkgName p == pkgname && pkgVersion p `withinRange` vrange
  --
  case filter ok ps of
    [] -> die ("cannot satisfy dependency " ++ 
			pkgname ++ showVersionRange vrange)
    qs -> let 
	    pkg = maximumBy versions qs
	    versions a b = pkgVersion a `compare` pkgVersion b
	  in do message ("Dependency " ++ pkgname ++ showVersionRange vrange ++
			 ": using " ++ showPackageId pkg)
		return pkg

getInstalledPackages :: Compiler -> ConfigFlags -> IO [PackageIdentifier]
getInstalledPackages comp cfg = do
   message "Reading installed packages..."
   withTempFile "." "" $ \tmp -> do
      let user_flag = if configUser cfg then " --user" else " --global"
          cmd_line  = compilerPkgTool comp ++ user_flag ++ " list >" ++ tmp
      when (configVerbose cfg > 0) $
        putStrLn cmd_line
      res <- system cmd_line
      case res of
        ExitFailure _ -> die ("cannot get package list")
        ExitSuccess -> do
	  str <- readFile tmp
	  let str1 = unlines (filter (':' `notElem`) (lines str))
	      str2 = filter (`notElem` ",()") str1
	  case pCheck (readP_to_S (many (skipSpaces >> parsePackageId)) str2) of
	    [ps] -> return ps
	    _   -> die "cannot parse package list"

system_default_prefix :: PackageDescription -> IO String
system_default_prefix _ = 
  return "/usr/local"

-- -----------------------------------------------------------------------------
-- Determining the compiler details

configCompiler :: ConfigFlags -> IO Compiler
configCompiler cfg
  = do let flavor = case configHcFlavor cfg of
                      Just f  -> f
                      Nothing -> defaultCompilerFlavor
       comp <- 
	 case configHcPath cfg of
	   Just path -> return path
	   Nothing   -> findCompiler flavor

       ver <- configCompilerVersion flavor comp cfg

       pkgtool <-
	 case configHcPkg cfg of
	   Just path -> return path
	   Nothing   -> guessPkgToolFromHCPath flavor comp

       return (Compiler{compilerFlavor=flavor,
			compilerVersion=ver,
			compilerPath=comp,
			compilerPkgTool=pkgtool})

defaultCompilerFlavor :: CompilerFlavor
defaultCompilerFlavor =

   Hugs

findCompiler :: CompilerFlavor -> IO FilePath
findCompiler flavor = do
  let prog = compilerBinaryName flavor
  message $ "searching for " ++ prog ++ " in path."
  res <- findExecutable prog
  case res of
   Nothing   -> die ("Cannot find compiler for " ++ prog)
   Just path -> do message ("found " ++ prog ++ " at "++ path)
		   return path
   -- ToDo: check that compiler works? check compiler version?

compilerBinaryName :: CompilerFlavor -> String
compilerBinaryName GHC  = "ghc"
compilerBinaryName NHC  = "hmake" -- FIX: uses hmake for now
compilerBinaryName Hugs = "ffihugs"
compilerBinaryName cmp  = error $ "Unsupported compiler: " ++ (show cmp)

compilerPkgToolName :: CompilerFlavor -> String
compilerPkgToolName GHC  = "ghc-pkg"
compilerPkgToolName NHC  = "hmake" -- FIX: nhc98-pkg Does not yet exist
compilerPkgToolName Hugs = "hugs" -- FIX (HUGS): hugs-pkg does not yet exist
compilerPkgToolName cmp  = error $ "Unsupported compiler: " ++ (show cmp)

configCompilerVersion :: CompilerFlavor -> FilePath -> ConfigFlags -> IO Version
configCompilerVersion GHC compilerP cfg =
  withTempFile "." "" $ \tmp -> do
    let cmd_line = compilerP ++ " --version >" ++ tmp
    when (configVerbose cfg > 0) $
      putStrLn cmd_line
    maybeExit $ system cmd_line
    str <- readFile tmp
    case pCheck (readP_to_S parseVersion (dropWhile (not.isDigit) str)) of
	[v] -> return v
	_   -> die ("cannot determine version of " ++ compilerP ++ ":\n  "
			++ str)
configCompilerVersion _ _ _ = return Version{ versionBranch=[],versionTags=[] }

pCheck :: [(a, [Char])] -> [a]
pCheck rs = [ r | (r,s) <- rs, all isSpace s ]

guessPkgToolFromHCPath :: CompilerFlavor -> FilePath -> IO FilePath
guessPkgToolFromHCPath flavor path
  = do let pkgToolName     = compilerPkgToolName flavor
           (dir,_,ext) = splitFilePath path
           pkgtool         = dir `joinFileName` pkgToolName `joinFileExt` ext
       message $ "looking for package tool: " ++ pkgToolName ++ " near compiler in " ++ path
       exists <- doesFileExist pkgtool
       when (not exists) $
	  die ("Cannot find package tool: " ++ pkgtool)
       message $ "found package tool in " ++ pkgtool
       return pkgtool

message :: String -> IO ()
message s = putStrLn $ "configure: " ++ s

-- -----------------------------------------------------------------------------
-- Tests

