Cabal/Distribution/Simple/UHC.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE RankNTypes #-}
   3
   4 -----------------------------------------------------------------------------
   5 -- |
   6 -- Module      :  Distribution.Simple.UHC
   7 -- Copyright   :  Andres Loeh 2009
   8 -- License     :  BSD3
   9 --
  10 -- Maintainer  :  cabal-devel@haskell.org
  11 -- Portability :  portable
  12 --
  13 -- This module contains most of the UHC-specific code for configuring, building
  14 -- and installing packages.
  15 --
  16 -- Thanks to the authors of the other implementation-specific files, in
  17 -- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for
  18 -- inspiration on how to design this module.
  19
  20 module Distribution.Simple.UHC (
  21     configure, getInstalledPackages,
  22     buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath
  23   ) where
  24
  25 import Prelude ()
  26 import Distribution.Compat.Prelude
  27
  28 import Distribution.Compat.ReadP
  29 import Distribution.InstalledPackageInfo
  30 import Distribution.Package hiding (installedUnitId)
  31 import Distribution.PackageDescription
  32 import Distribution.Simple.BuildPaths
  33 import Distribution.Simple.Compiler as C
  34 import Distribution.Simple.LocalBuildInfo
  35 import Distribution.Simple.PackageIndex
  36 import Distribution.Simple.Program
  37 import Distribution.Simple.Utils
  38 import Distribution.Text
  39 import Distribution.Types.MungedPackageId
  40 import Distribution.Verbosity
  41 import Distribution.Version
  42 import Distribution.System
  43 import Language.Haskell.Extension
  44
  45 import qualified Data.Map as Map ( empty )
  46 import System.Directory
  47 import System.FilePath
  48
  49 -- -----------------------------------------------------------------------------
  50 -- Configuring
  51
  52 configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
  53           -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)
  54 configure verbosity hcPath _hcPkgPath progdb = do
  55
  56   (_uhcProg, uhcVersion, progdb') <-
  57     requireProgramVersion verbosity uhcProgram
  58     (orLaterVersion (mkVersion [1,0,2]))
  59     (userMaybeSpecifyPath "uhc" hcPath progdb)
  60
  61   let comp = Compiler {
  62                compilerId         =  CompilerId UHC uhcVersion,
  63                compilerAbiTag     =  C.NoAbiTag,
  64                compilerCompat     =  [],
  65                compilerLanguages  =  uhcLanguages,
  66                compilerExtensions =  uhcLanguageExtensions,
  67                compilerProperties =  Map.empty
  68              }
  69       compPlatform = Nothing
  70   return (comp, compPlatform, progdb')
  71
  72 uhcLanguages :: [(Language, C.Flag)]
  73 uhcLanguages = [(Haskell98, "")]
  74
  75 -- | The flags for the supported extensions.
  76 uhcLanguageExtensions :: [(Extension, Maybe C.Flag)]
  77 uhcLanguageExtensions =
  78     let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),
  79                                          (DisableExtension f, disable)]
  80         alwaysOn = (Nothing, Nothing{- wrong -})
  81     in concatMap doFlag
  82     [(CPP,                          (Just "--cpp", Nothing{- wrong -})),
  83      (PolymorphicComponents,        alwaysOn),
  84      (ExistentialQuantification,    alwaysOn),
  85      (ForeignFunctionInterface,     alwaysOn),
  86      (UndecidableInstances,         alwaysOn),
  87      (MultiParamTypeClasses,        alwaysOn),
  88      (Rank2Types,                   alwaysOn),
  89      (PatternSignatures,            alwaysOn),
  90      (EmptyDataDecls,               alwaysOn),
  91      (ImplicitPrelude,              (Nothing, Just "--no-prelude"{- wrong -})),
  92      (TypeOperators,                alwaysOn),
  93      (OverlappingInstances,         alwaysOn),
  94      (FlexibleInstances,            alwaysOn)]
  95
  96 getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb
  97                      -> IO InstalledPackageIndex
  98 getInstalledPackages verbosity comp packagedbs progdb = do
  99   let compilerid = compilerId comp
 100   systemPkgDir <- getGlobalPackageDir verbosity progdb
 101   userPkgDir   <- getUserPackageDir
 102   let pkgDirs    = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)
 103   -- putStrLn $ "pkgdirs: " ++ show pkgDirs
 104   pkgs <- liftM (map addBuiltinVersions . concat) $
 105           traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d))
 106           pkgDirs
 107   -- putStrLn $ "pkgs: " ++ show pkgs
 108   let iPkgs =
 109         map mkInstalledPackageInfo $
 110         concatMap parsePackage $
 111         pkgs
 112   -- putStrLn $ "installed pkgs: " ++ show iPkgs
 113   return (fromList iPkgs)
 114
 115 getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath
 116 getGlobalPackageDir verbosity progdb = do
 117     output <- getDbProgramOutput verbosity
 118                 uhcProgram progdb ["--meta-pkgdir-system"]
 119     -- call to "lines" necessary, because pkgdir contains an extra newline at the end
 120     let [pkgdir] = lines output
 121     return pkgdir
 122
 123 getUserPackageDir :: NoCallStackIO FilePath
 124 getUserPackageDir = do
 125     homeDir <- getHomeDirectory
 126     return $ homeDir </> ".cabal" </> "lib"  -- TODO: determine in some other way
 127
 128 packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]
 129 packageDbPaths user system db =
 130   case db of
 131     GlobalPackageDB         ->  [ system ]
 132     UserPackageDB           ->  [ user ]
 133     SpecificPackageDB path  ->  [ path ]
 134
 135 -- | Hack to add version numbers to UHC-built-in packages. This should sooner or
 136 -- later be fixed on the UHC side.
 137 addBuiltinVersions :: String -> String
 138 {-
 139 addBuiltinVersions "uhcbase"  = "uhcbase-1.0"
 140 addBuiltinVersions "base"  = "base-3.0"
 141 addBuiltinVersions "array" = "array-0.2"
 142 -}
 143 addBuiltinVersions xs      = xs
 144
 145 -- | Name of the installed package config file.
 146 installedPkgConfig :: String
 147 installedPkgConfig = "installed-pkg-config"
 148
 149 -- | Check if a certain dir contains a valid package. Currently, we are
 150 -- looking only for the presence of an installed package configuration.
 151 -- TODO: Actually make use of the information provided in the file.
 152 isPkgDir :: String -> String -> String -> NoCallStackIO Bool
 153 isPkgDir _ _   ('.' : _)  = return False  -- ignore files starting with a .
 154 isPkgDir c dir xs         = do
 155                               let candidate = dir </> uhcPackageDir xs c
 156                               -- putStrLn $ "trying: " ++ candidate
 157                               doesFileExist (candidate </> installedPkgConfig)
 158
 159 parsePackage :: String -> [PackageId]
 160 parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x))
 161
 162 -- | Create a trivial package info from a directory name.
 163 mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo
 164 mkInstalledPackageInfo p = emptyInstalledPackageInfo
 165   { installedUnitId = mkLegacyUnitId p,
 166     sourcePackageId = p }
 167
 168
 169 -- -----------------------------------------------------------------------------
 170 -- Building
 171
 172 buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
 173                       -> Library            -> ComponentLocalBuildInfo -> IO ()
 174 buildLib verbosity pkg_descr lbi lib clbi = do
 175
 176   systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)
 177   userPkgDir   <- getUserPackageDir
 178   let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)
 179   let uhcArgs =    -- set package name
 180                    ["--pkg-build=" ++ display (packageId pkg_descr)]
 181                    -- common flags lib/exe
 182                 ++ constructUHCCmdLine userPkgDir systemPkgDir
 183                                        lbi (libBuildInfo lib) clbi
 184                                        (buildDir lbi) verbosity
 185                    -- source files
 186                    -- suboptimal: UHC does not understand module names, so
 187                    -- we replace periods by path separators
 188                 ++ map (map (\ c -> if c == '.' then pathSeparator else c))
 189                        (map display (allLibModules lib clbi))
 190
 191   runUhcProg uhcArgs
 192
 193   return ()
 194
 195 buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
 196                       -> Executable         -> ComponentLocalBuildInfo -> IO ()
 197 buildExe verbosity _pkg_descr lbi exe clbi = do
 198   systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)
 199   userPkgDir   <- getUserPackageDir
 200   let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)
 201   let uhcArgs =    -- common flags lib/exe
 202                    constructUHCCmdLine userPkgDir systemPkgDir
 203                                        lbi (buildInfo exe) clbi
 204                                        (buildDir lbi) verbosity
 205                    -- output file
 206                 ++ ["--output", buildDir lbi </> display (exeName exe)]
 207                    -- main source module
 208                 ++ [modulePath exe]
 209   runUhcProg uhcArgs
 210
 211 constructUHCCmdLine :: FilePath -> FilePath
 212                     -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
 213                     -> FilePath -> Verbosity -> [String]
 214 constructUHCCmdLine user system lbi bi clbi odir verbosity =
 215      -- verbosity
 216      (if      verbosity >= deafening then ["-v4"]
 217       else if verbosity >= normal    then []
 218       else                                ["-v0"])
 219   ++ hcOptions UHC bi
 220      -- flags for language extensions
 221   ++ languageToFlags   (compiler lbi) (defaultLanguage bi)
 222   ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
 223      -- packages
 224   ++ ["--hide-all-packages"]
 225   ++ uhcPackageDbOptions user system (withPackageDB lbi)
 226   ++ ["--package=uhcbase"]
 227   ++ ["--package=" ++ display (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ]
 228      -- search paths
 229   ++ ["-i" ++ odir]
 230   ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]
 231   ++ ["-i" ++ autogenComponentModulesDir lbi clbi]
 232   ++ ["-i" ++ autogenPackageModulesDir lbi]
 233      -- cpp options
 234   ++ ["--optP=" ++ opt | opt <- cppOptions bi]
 235      -- output path
 236   ++ ["--odir=" ++ odir]
 237      -- optimization
 238   ++ (case withOptimization lbi of
 239         NoOptimisation       ->  ["-O0"]
 240         NormalOptimisation   ->  ["-O1"]
 241         MaximumOptimisation  ->  ["-O2"])
 242
 243 uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String]
 244 uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x)
 245                                          (concatMap (packageDbPaths user system) db)
 246
 247 -- -----------------------------------------------------------------------------
 248 -- Installation
 249
 250 installLib :: Verbosity -> LocalBuildInfo
 251            -> FilePath -> FilePath -> FilePath
 252            -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO ()
 253 installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do
 254     -- putStrLn $ "dest:  " ++ targetDir
 255     -- putStrLn $ "built: " ++ builtDir
 256     installDirectoryContents verbosity (builtDir </> display (packageId pkg)) targetDir
 257
 258 -- currently hard-coded UHC code generator and variant to use
 259 uhcTarget, uhcTargetVariant :: String
 260 uhcTarget        = "bc"
 261 uhcTargetVariant = "plain"
 262
 263 -- root directory for a package in UHC
 264 uhcPackageDir    :: String -> String -> FilePath
 265 uhcPackageSubDir ::           String -> FilePath
 266 uhcPackageDir    pkgid compilerid = pkgid </> uhcPackageSubDir compilerid
 267 uhcPackageSubDir       compilerid = compilerid </> uhcTarget </> uhcTargetVariant
 268
 269 -- -----------------------------------------------------------------------------
 270 -- Registering
 271
 272 registerPackage
 273   :: Verbosity
 274   -> Compiler
 275   -> ProgramDb
 276   -> PackageDBStack
 277   -> InstalledPackageInfo
 278   -> IO ()
 279 registerPackage verbosity comp progdb packageDbs installedPkgInfo = do
 280     dbdir <- case last packageDbs of
 281       GlobalPackageDB       -> getGlobalPackageDir verbosity progdb
 282       UserPackageDB         -> getUserPackageDir
 283       SpecificPackageDB dir -> return dir
 284     let pkgdir = dbdir </> uhcPackageDir (display pkgid) (display compilerid)
 285     createDirectoryIfMissingVerbose verbosity True pkgdir
 286     writeUTF8File (pkgdir </> installedPkgConfig)
 287                   (showInstalledPackageInfo installedPkgInfo)
 288   where
 289     pkgid      = sourcePackageId installedPkgInfo
 290     compilerid = compilerId comp
 291
 292 inplacePackageDbPath :: LocalBuildInfo -> FilePath
 293 inplacePackageDbPath lbi = buildDir lbi