UHC.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.UHC
-- Copyright   :  Andres Loeh 2009
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module contains most of the UHC-specific code for configuring, building
-- and installing packages.
--
-- Thanks to the authors of the other implementation-specific files, in
-- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for
-- inspiration on how to design this module.

module Distribution.Simple.UHC (
    configure, getInstalledPackages,
    buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.InstalledPackageInfo
import Distribution.Package hiding (installedUnitId)
import Distribution.PackageDescription
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Utils
import Distribution.Pretty
import Distribution.Parsec
import Distribution.Types.MungedPackageId
import Distribution.Verbosity
import Distribution.Version
import Distribution.System
import Language.Haskell.Extension
import Distribution.Utils.Path

import qualified Data.Map as Map ( empty )
import System.Directory
import System.FilePath

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

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

  (_uhcProg, uhcVersion, progdb') <-
    requireProgramVersion verbosity uhcProgram
    (orLaterVersion (mkVersion [1,0,2]))
    (userMaybeSpecifyPath "uhc" hcPath progdb)

  let comp = Compiler {
               compilerId         =  CompilerId UHC uhcVersion,
               compilerAbiTag     =  NoAbiTag,
               compilerCompat     =  [],
               compilerLanguages  =  uhcLanguages,
               compilerExtensions =  uhcLanguageExtensions,
               compilerProperties =  Map.empty
             }
      compPlatform = Nothing
  return (comp, compPlatform, progdb')

uhcLanguages :: [(Language, CompilerFlag)]
uhcLanguages = [(Haskell98, "")]

-- | The flags for the supported extensions.
uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)]
uhcLanguageExtensions =
    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),
                                         (DisableExtension f, disable)]
        alwaysOn = (Nothing, Nothing{- wrong -})
    in concatMap doFlag
    [(CPP,                          (Just "--cpp", Nothing{- wrong -})),
     (PolymorphicComponents,        alwaysOn),
     (ExistentialQuantification,    alwaysOn),
     (ForeignFunctionInterface,     alwaysOn),
     (UndecidableInstances,         alwaysOn),
     (MultiParamTypeClasses,        alwaysOn),
     (Rank2Types,                   alwaysOn),
     (PatternSignatures,            alwaysOn),
     (EmptyDataDecls,               alwaysOn),
     (ImplicitPrelude,              (Nothing, Just "--no-prelude"{- wrong -})),
     (TypeOperators,                alwaysOn),
     (OverlappingInstances,         alwaysOn),
     (FlexibleInstances,            alwaysOn)]

getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb
                     -> IO InstalledPackageIndex
getInstalledPackages verbosity comp packagedbs progdb = do
  let compilerid = compilerId comp
  systemPkgDir <- getGlobalPackageDir verbosity progdb
  userPkgDir   <- getUserPackageDir
  let pkgDirs    = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)
  -- putStrLn $ "pkgdirs: " ++ show pkgDirs
  pkgs <- liftM (map addBuiltinVersions . concat) $
          traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d))
          pkgDirs
  -- putStrLn $ "pkgs: " ++ show pkgs
  let iPkgs =
        map mkInstalledPackageInfo $
        concatMap parsePackage $
        pkgs
  -- putStrLn $ "installed pkgs: " ++ show iPkgs
  return (fromList iPkgs)

getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath
getGlobalPackageDir verbosity progdb = do
    output <- getDbProgramOutput verbosity
                uhcProgram progdb ["--meta-pkgdir-system"]
    -- we need to trim because pkgdir contains an extra newline at the end
    let pkgdir = trimEnd output
    return pkgdir
  where
    trimEnd = reverse . dropWhile isSpace . reverse

getUserPackageDir :: IO FilePath
getUserPackageDir = do
    homeDir <- getHomeDirectory
    return $ homeDir </> ".cabal" </> "lib"  -- TODO: determine in some other way

packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]
packageDbPaths user system db =
  case db of
    GlobalPackageDB         ->  [ system ]
    UserPackageDB           ->  [ user ]
    SpecificPackageDB path  ->  [ path ]

-- | Hack to add version numbers to UHC-built-in packages. This should sooner or
-- later be fixed on the UHC side.
addBuiltinVersions :: String -> String
{-
addBuiltinVersions "uhcbase"  = "uhcbase-1.0"
addBuiltinVersions "base"  = "base-3.0"
addBuiltinVersions "array" = "array-0.2"
-}
addBuiltinVersions xs      = xs

-- | Name of the installed package config file.
installedPkgConfig :: String
installedPkgConfig = "installed-pkg-config"

-- | Check if a certain dir contains a valid package. Currently, we are
-- looking only for the presence of an installed package configuration.
-- TODO: Actually make use of the information provided in the file.
isPkgDir :: String -> String -> String -> IO Bool
isPkgDir _ _   ('.' : _)  = return False  -- ignore files starting with a .
isPkgDir c dir xs         = do
                              let candidate = dir </> uhcPackageDir xs c
                              -- putStrLn $ "trying: " ++ candidate
                              doesFileExist (candidate </> installedPkgConfig)

parsePackage :: String -> [PackageId]
parsePackage = toList  . simpleParsec

-- | Create a trivial package info from a directory name.
mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo
mkInstalledPackageInfo p = emptyInstalledPackageInfo
  { installedUnitId = mkLegacyUnitId p,
    sourcePackageId = p }


-- -----------------------------------------------------------------------------
-- Building

buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
                      -> Library            -> ComponentLocalBuildInfo -> IO ()
buildLib verbosity pkg_descr lbi lib clbi = do

  systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)
  userPkgDir   <- getUserPackageDir
  let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)
  let uhcArgs =    -- set package name
                   ["--pkg-build=" ++ prettyShow (packageId pkg_descr)]
                   -- common flags lib/exe
                ++ constructUHCCmdLine userPkgDir systemPkgDir
                                       lbi (libBuildInfo lib) clbi
                                       (buildDir lbi) verbosity
                   -- source files
                   -- suboptimal: UHC does not understand module names, so
                   -- we replace periods by path separators
                ++ map (map (\ c -> if c == '.' then pathSeparator else c))
                       (map prettyShow (allLibModules lib clbi))

  runUhcProg uhcArgs

  return ()

buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
                      -> Executable         -> ComponentLocalBuildInfo -> IO ()
buildExe verbosity _pkg_descr lbi exe clbi = do
  systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)
  userPkgDir   <- getUserPackageDir
  let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)
  let uhcArgs =    -- common flags lib/exe
                   constructUHCCmdLine userPkgDir systemPkgDir
                                       lbi (buildInfo exe) clbi
                                       (buildDir lbi) verbosity
                   -- output file
                ++ ["--output", buildDir lbi </> prettyShow (exeName exe)]
                   -- main source module
                ++ [modulePath exe]
  runUhcProg uhcArgs

constructUHCCmdLine :: FilePath -> FilePath
                    -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
                    -> FilePath -> Verbosity -> [String]
constructUHCCmdLine user system lbi bi clbi odir verbosity =
     -- verbosity
     (if      verbosity >= deafening then ["-v4"]
      else if verbosity >= normal    then []
      else                                ["-v0"])
  ++ hcOptions UHC bi
     -- flags for language extensions
  ++ languageToFlags   (compiler lbi) (defaultLanguage bi)
  ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
     -- packages
  ++ ["--hide-all-packages"]
  ++ uhcPackageDbOptions user system (withPackageDB lbi)
  ++ ["--package=uhcbase"]
  ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ]
     -- search paths
  ++ ["-i" ++ odir]
  ++ ["-i" ++ getSymbolicPath l | l <- nub (hsSourceDirs bi)]
  ++ ["-i" ++ autogenComponentModulesDir lbi clbi]
  ++ ["-i" ++ autogenPackageModulesDir lbi]
     -- cpp options
  ++ ["--optP=" ++ opt | opt <- cppOptions bi]
     -- output path
  ++ ["--odir=" ++ odir]
     -- optimization
  ++ (case withOptimization lbi of
        NoOptimisation       ->  ["-O0"]
        NormalOptimisation   ->  ["-O1"]
        MaximumOptimisation  ->  ["-O2"])

uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String]
uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x)
                                         (concatMap (packageDbPaths user system) db)

-- -----------------------------------------------------------------------------
-- Installation

installLib :: Verbosity -> LocalBuildInfo
           -> FilePath -> FilePath -> FilePath
           -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO ()
installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do
    -- putStrLn $ "dest:  " ++ targetDir
    -- putStrLn $ "built: " ++ builtDir
    installDirectoryContents verbosity (builtDir </> prettyShow (packageId pkg)) targetDir

-- currently hard-coded UHC code generator and variant to use
uhcTarget, uhcTargetVariant :: String
uhcTarget        = "bc"
uhcTargetVariant = "plain"

-- root directory for a package in UHC
uhcPackageDir    :: String -> String -> FilePath
uhcPackageSubDir ::           String -> FilePath
uhcPackageDir    pkgid compilerid = pkgid </> uhcPackageSubDir compilerid
uhcPackageSubDir       compilerid = compilerid </> uhcTarget </> uhcTargetVariant

-- -----------------------------------------------------------------------------
-- Registering

registerPackage
  :: Verbosity
  -> Compiler
  -> ProgramDb
  -> PackageDBStack
  -> InstalledPackageInfo
  -> IO ()
registerPackage verbosity comp progdb packageDbs installedPkgInfo = do
    dbdir <- case registrationPackageDB packageDbs of
      GlobalPackageDB       -> getGlobalPackageDir verbosity progdb
      UserPackageDB         -> getUserPackageDir
      SpecificPackageDB dir -> return dir
    let pkgdir = dbdir </> uhcPackageDir (prettyShow pkgid) (prettyShow compilerid)
    createDirectoryIfMissingVerbose verbosity True pkgdir
    writeUTF8File (pkgdir </> installedPkgConfig)
                  (showInstalledPackageInfo installedPkgInfo)
  where
    pkgid      = sourcePackageId installedPkgInfo
    compilerid = compilerId comp

inplacePackageDbPath :: LocalBuildInfo -> FilePath
inplacePackageDbPath lbi = buildDir lbi