-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Hugs
-- Copyright   :  Isaac Jones 2003-2006
--                Duncan Coutts 2009
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module contains most of the NHC-specific code for configuring, building
-- and installing packages.

module Distribution.Simple.Hugs (
    configure,
    getInstalledPackages,
    buildLib,
    buildExe,
    install,
    registerPackage,
  ) where

import Distribution.Package
         ( PackageName, PackageIdentifier(..), InstalledPackageId(..)
         , packageName )
import Distribution.InstalledPackageInfo
         ( InstalledPackageInfo, emptyInstalledPackageInfo
         , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId
                                , sourcePackageId )
         , parseInstalledPackageInfo, showInstalledPackageInfo )
import Distribution.PackageDescription
         ( PackageDescription(..), BuildInfo(..), hcOptions, allExtensions
         , Executable(..), withExe, Library(..), withLib, libModules )
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
import Distribution.Simple.Compiler
         ( CompilerFlavor(..), CompilerId(..)
         , Compiler(..), Flag, languageToFlags, extensionsToFlags
         , PackageDB(..), PackageDBStack )
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Simple.Program
         ( Program(programFindVersion)
         , ProgramConfiguration, userMaybeSpecifyPath
         , requireProgram, requireProgramVersion
         , rawSystemProgramConf, programPath
         , ffihugsProgram, hugsProgram )
import Distribution.Version
         ( Version(..), orLaterVersion )
import Distribution.Simple.PreProcess   ( ppCpp, runSimplePreProcessor )
import Distribution.Simple.PreProcess.Unlit
                                ( unlit )
import Distribution.Simple.LocalBuildInfo
         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)
         , InstallDirs(..), absoluteInstallDirs )
import Distribution.Simple.BuildPaths
                                ( autogenModuleName, autogenModulesDir,
                                  dllExtension )
import Distribution.Simple.Setup
         ( CopyDest(..) )
import Distribution.Simple.Utils
         ( createDirectoryIfMissingVerbose
         , installOrdinaryFiles, setFileExecutable
         , withUTF8FileContents, writeFileAtomic, writeUTF8File
         , copyFileVerbose, findFile, findFileWithExtension, findModuleFiles
         , rawSystemStdInOut
         , die, info, notice )
import Language.Haskell.Extension
         ( Language(Haskell98), Extension(..), KnownExtension(..) )
import System.FilePath          ( (</>), takeExtension, (<.>),
                                  searchPathSeparator, normalise, takeDirectory )
import Distribution.System
         ( OS(..), buildOS )
import Distribution.Text
         ( display, simpleParse )
import Distribution.ParseUtils
         ( ParseResult(..) )
import Distribution.Verbosity

import Data.Char                ( isSpace )
import qualified Data.Map as M  ( empty )
import Data.Maybe               ( mapMaybe, catMaybes )
import Data.Monoid              ( Monoid(..) )
import Control.Monad            ( unless, when, filterM )
import Data.List                ( nub, sort, isSuffixOf )
import System.Directory
         ( doesFileExist, doesDirectoryExist, getDirectoryContents
         , removeDirectoryRecursive, getHomeDirectory )
import System.Exit
         ( ExitCode(ExitSuccess) )
import Distribution.Compat.Exception
import Distribution.System ( Platform )

import qualified Data.ByteString.Lazy.Char8 as BS.Char8

-- -----------------------------------------------------------------------------
-- Configuring

configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)
configure verbosity hcPath _hcPkgPath conf = do

  (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram
                            (userMaybeSpecifyPath "ffihugs" hcPath conf)
  (_hugsProg, version, conf'')
                        <- requireProgramVersion verbosity hugsProgram'
                            (orLaterVersion (Version [2006] [])) conf'

  let comp = Compiler {
        compilerId             = CompilerId Hugs version,
        compilerLanguages      = hugsLanguages,
        compilerExtensions     = hugsLanguageExtensions,
        compilerProperties     = M.empty
      }
      compPlatform = Nothing
  return (comp, compPlatform, conf'')

  where
    hugsProgram' = hugsProgram { programFindVersion = getVersion }

getVersion :: Verbosity -> FilePath -> IO (Maybe Version)
getVersion verbosity hugsPath = do
  (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath []
                              Nothing Nothing
                              (Just (":quit", False)) False
  if exit == ExitSuccess
    then return $! findVersion output
    else return Nothing

  where
    findVersion output = do
      (monthStr, yearStr) <- selectWords output
      year  <- convertYear yearStr
      month <- convertMonth monthStr
      return (Version [year, month] [])

    selectWords output =
      case [ (month, year)
           | [_,_,"Version:", month, year,_] <- map words (lines output) ] of
        [(month, year)] -> Just (month, year)
        _               -> Nothing
    convertYear year = case reads year of
      [(y, [])] | y >= 1999 && y < 2020 -> Just y
      _                                 -> Nothing
    convertMonth month = lookup month (zip months [1..])
    months = [ "January", "February", "March", "April", "May", "June", "July"
             , "August", "September", "October", "November", "December" ]

hugsLanguages :: [(Language, Flag)]
hugsLanguages = [(Haskell98, "")] --default is 98 mode

-- | The flags for the supported extensions
hugsLanguageExtensions :: [(Extension, Flag)]
hugsLanguageExtensions =
    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),
                                         (DisableExtension f, disable)]
        alwaysOn = ("", ""{- wrong -})
        ext98 = ("-98", ""{- wrong -})
    in concatMap doFlag
    [(OverlappingInstances       , ("+o",  "-o"))
    ,(IncoherentInstances        , ("+oO", "-O"))
    ,(HereDocuments              , ("+H",  "-H"))
    ,(TypeSynonymInstances       , ext98)
    ,(RecursiveDo                , ext98)
    ,(ParallelListComp           , ext98)
    ,(MultiParamTypeClasses      , ext98)
    ,(FunctionalDependencies     , ext98)
    ,(Rank2Types                 , ext98)
    ,(PolymorphicComponents      , ext98)
    ,(ExistentialQuantification  , ext98)
    ,(ScopedTypeVariables        , ext98)
    ,(ImplicitParams             , ext98)
    ,(ExtensibleRecords          , ext98)
    ,(RestrictedTypeSynonyms     , ext98)
    ,(FlexibleContexts           , ext98)
    ,(FlexibleInstances          , ext98)
    ,(ForeignFunctionInterface   , alwaysOn)
    ,(EmptyDataDecls             , alwaysOn)
    ,(CPP                        , alwaysOn)
    ]

getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
                     -> IO PackageIndex
getInstalledPackages verbosity packagedbs conf = do
  homedir       <- getHomeDirectory
  (hugsProg, _) <- requireProgram verbosity hugsProgram conf
  let hugsbindir = takeDirectory (programPath hugsProg)
      hugslibdir = takeDirectory hugsbindir </> "lib" </> "hugs"
      dbdirs = nub (concatMap (packageDbPaths homedir hugslibdir) packagedbs)
  indexes  <- mapM getIndividualDBPackages dbdirs
  return $! mconcat indexes

  where
    getIndividualDBPackages :: FilePath -> IO PackageIndex
    getIndividualDBPackages dbdir = do
      pkgdirs <- getPackageDbDirs dbdir
      pkgs    <- sequence [ getInstalledPackage pkgname pkgdir
                          | (pkgname, pkgdir) <- pkgdirs ]
      let pkgs' = map setInstalledPackageId (catMaybes pkgs)
      return (PackageIndex.fromList pkgs')

packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]
packageDbPaths home hugslibdir db = case db of
  GlobalPackageDB        -> [ hugslibdir </> "packages"
                            , "/usr/local/lib/hugs/packages" ]
  UserPackageDB          -> [ home </> "lib/hugs/packages" ]
  SpecificPackageDB path -> [ path ]

getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)]
getPackageDbDirs dbdir = do
  dbexists <- doesDirectoryExist dbdir
  if not dbexists
    then return []
    else do
      entries  <- getDirectoryContents dbdir
      pkgdirs  <- sequence
        [ do pkgdirExists <- doesDirectoryExist pkgdir
             return (pkgname, pkgdir, pkgdirExists)
        | (entry, Just pkgname) <- [ (entry, simpleParse entry)
                                   | entry <- entries ]
        , let pkgdir = dbdir </> entry ]
      return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ]

getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo)
getInstalledPackage pkgname pkgdir = do
  let pkgconfFile = pkgdir </> "package.conf"
  pkgconfExists <- doesFileExist pkgconfFile

  let pathsModule = pkgdir </> ("Paths_" ++ display pkgname)  <.> "hs"
  pathsModuleExists <- doesFileExist pathsModule

  case () of
    _ | pkgconfExists     -> getFullInstalledPackageInfo pkgname pkgconfFile
      | pathsModuleExists -> getPhonyInstalledPackageInfo pkgname pathsModule
      | otherwise         -> return Nothing

getFullInstalledPackageInfo :: PackageName -> FilePath
                            -> IO (Maybe InstalledPackageInfo)
getFullInstalledPackageInfo pkgname pkgconfFile =
  withUTF8FileContents pkgconfFile $ \contents ->
    case parseInstalledPackageInfo contents of
      ParseOk _ pkginfo | packageName pkginfo == pkgname
                        -> return (Just pkginfo)
      _                 -> return Nothing

-- | This is a backup option for existing versions of Hugs which do not supply
-- proper installed package info files for the bundled libs. Instead we look
-- for the Paths_pkgname.hs file and extract the package version from that.
-- We don't know any other details for such packages, in particular we pretend
-- that they have no dependencies.
--
getPhonyInstalledPackageInfo :: PackageName -> FilePath
                             -> IO (Maybe InstalledPackageInfo)
getPhonyInstalledPackageInfo pkgname pathsModule = do
  content <- readFile pathsModule