Cabal/src/Distribution/Simple/UHC.hs

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