Distribution/Simple/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.Compat.ReadP
    import Distribution.InstalledPackageInfo
    import Distribution.Package hiding (installedUnitId)
    import Distribution.PackageDescription
    import Distribution.Simple.BuildPaths
    import Distribution.Simple.Compiler as C
    import Distribution.Simple.LocalBuildInfo
    import Distribution.Simple.PackageIndex
    import Distribution.Simple.Program
    import Distribution.Simple.Utils
    import Distribution.Text
    import Distribution.Types.MungedPackageId
    import Distribution.Verbosity
    import Distribution.Version
    import Distribution.System
    import Language.Haskell.Extension

    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     =  C.NoAbiTag,
                   compilerCompat     =  [],
                   compilerLanguages  =  uhcLanguages,
                   compilerExtensions =  uhcLanguageExtensions,
                   compilerProperties =  Map.empty
                 }
          compPlatform = Nothing
      return (comp, compPlatform, progdb')

    uhcLanguages :: [(Language, C.Flag)]
    uhcLanguages = [(Haskell98, "")]

    -- | The flags for the supported extensions.
    uhcLanguageExtensions :: [(Extension, C.Flag)]
    uhcLanguageExtensions =
        let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),
                                             (DisableExtension f, disable)]
            alwaysOn = ("", ""{- wrong -})
        in concatMap doFlag
        [(CPP,                          ("--cpp", ""{- wrong -})),
         (PolymorphicComponents,        alwaysOn),
         (ExistentialQuantification,    alwaysOn),
         (ForeignFunctionInterface,     alwaysOn),
         (UndecidableInstances,         alwaysOn),
         (MultiParamTypeClasses,        alwaysOn),
         (Rank2Types,                   alwaysOn),
         (PatternSignatures,            alwaysOn),
         (EmptyDataDecls,               alwaysOn),
         (ImplicitPrelude,              ("", "--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 (display 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"]
        -- call to "lines" necessary, because pkgdir contains an extra newline at the end
        let [pkgdir] = lines output
        return pkgdir

    getUserPackageDir :: NoCallStackIO 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 -> NoCallStackIO 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 x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x))

    -- | 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=" ++ display (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 display (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 </> display (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=" ++ display (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ]
         -- search paths
      ++ ["-i" ++ odir]
      ++ ["-i" ++ 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 </> display (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 last packageDbs of
          GlobalPackageDB       -> getGlobalPackageDir verbosity progdb
          UserPackageDB         -> getUserPackageDir
          SpecificPackageDB dir -> return dir
        let pkgdir = dbdir </> uhcPackageDir (display pkgid) (display compilerid)
        createDirectoryIfMissingVerbose verbosity True pkgdir
        writeUTF8File (pkgdir </> installedPkgConfig)
                      (showInstalledPackageInfo installedPkgInfo)
      where
        pkgid      = sourcePackageId installedPkgInfo
        compilerid = compilerId comp

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