UHC.hs 11.4 KB
Newer Older
1 2 3
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

Andres Loeh's avatar
Andres Loeh committed
4 5 6 7
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.UHC
-- Copyright   :  Andres Loeh 2009
8
-- License     :  BSD3
Andres Loeh's avatar
Andres Loeh committed
9 10 11 12 13 14
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module contains most of the UHC-specific code for configuring, building
-- and installing packages.
15 16 17 18
--
-- 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.
Andres Loeh's avatar
Andres Loeh committed
19 20

module Distribution.Simple.UHC (
21
    configure, getInstalledPackages,
22
    buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath
Andres Loeh's avatar
Andres Loeh committed
23 24
  ) where

25 26 27
import Prelude ()
import Distribution.Compat.Prelude

28 29
import Distribution.Compat.ReadP
import Distribution.InstalledPackageInfo
30
import Distribution.Package hiding (installedUnitId)
Andres Loeh's avatar
Andres Loeh committed
31 32 33 34
import Distribution.PackageDescription
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler as C
import Distribution.Simple.LocalBuildInfo
35
import Distribution.Simple.PackageIndex
Andres Loeh's avatar
Andres Loeh committed
36
import Distribution.Simple.Program
37
import Distribution.Simple.Utils
Andres Loeh's avatar
Andres Loeh committed
38 39 40
import Distribution.Text
import Distribution.Verbosity
import Distribution.Version
41
import Distribution.System
Andres Loeh's avatar
Andres Loeh committed
42
import Language.Haskell.Extension
43

44
import qualified Data.Map as Map ( empty )
45
import System.Directory
Andres Loeh's avatar
Andres Loeh committed
46 47 48 49 50 51
import System.FilePath

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

configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
52
          -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
53
configure verbosity hcPath _hcPkgPath progdb = do
Andres Loeh's avatar
Andres Loeh committed
54

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
55
  (_uhcProg, uhcVersion, progdb') <-
Andres Loeh's avatar
Andres Loeh committed
56
    requireProgramVersion verbosity uhcProgram
57
    (orLaterVersion (mkVersion [1,0,2]))
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
58
    (userMaybeSpecifyPath "uhc" hcPath progdb)
Andres Loeh's avatar
Andres Loeh committed
59 60

  let comp = Compiler {
61
               compilerId         =  CompilerId UHC uhcVersion,
62 63
               compilerAbiTag     =  C.NoAbiTag,
               compilerCompat     =  [],
64
               compilerLanguages  =  uhcLanguages,
65
               compilerExtensions =  uhcLanguageExtensions,
66
               compilerProperties =  Map.empty
Andres Loeh's avatar
Andres Loeh committed
67
             }
68
      compPlatform = Nothing
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
69
  return (comp, compPlatform, progdb')
Andres Loeh's avatar
Andres Loeh committed
70

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

Andres Loeh's avatar
Andres Loeh committed
74
-- | The flags for the supported extensions.
75
uhcLanguageExtensions :: [(Extension, C.Flag)]
76
uhcLanguageExtensions =
77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93
    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)]
94

95
getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb
96
                     -> IO InstalledPackageIndex
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
97
getInstalledPackages verbosity comp packagedbs progdb = do
98
  let compilerid = compilerId comp
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
99
  systemPkgDir <- getGlobalPackageDir verbosity progdb
100 101 102
  userPkgDir   <- getUserPackageDir
  let pkgDirs    = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)
  -- putStrLn $ "pkgdirs: " ++ show pkgDirs
103
  pkgs <- liftM (map addBuiltinVersions . concat) $
104
          traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d))
105
          pkgDirs
106 107 108 109 110 111 112 113
  -- putStrLn $ "pkgs: " ++ show pkgs
  let iPkgs =
        map mkInstalledPackageInfo $
        concatMap parsePackage $
        pkgs
  -- putStrLn $ "installed pkgs: " ++ show iPkgs
  return (fromList iPkgs)

114
getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
115
getGlobalPackageDir verbosity progdb = do
116
    output <- getDbProgramOutput verbosity
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
117
                uhcProgram progdb ["--meta-pkgdir-system"]
118 119 120 121
    -- call to "lines" necessary, because pkgdir contains an extra newline at the end
    let [pkgdir] = lines output
    return pkgdir

122
getUserPackageDir :: NoCallStackIO FilePath
123
getUserPackageDir = do
124 125 126 127 128 129 130 131 132 133
    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 ]

Ian D. Bollinger's avatar
Ian D. Bollinger committed
134
-- | Hack to add version numbers to UHC-built-in packages. This should sooner or
135 136
-- later be fixed on the UHC side.
addBuiltinVersions :: String -> String
137 138
{-
addBuiltinVersions "uhcbase"  = "uhcbase-1.0"
139 140
addBuiltinVersions "base"  = "base-3.0"
addBuiltinVersions "array" = "array-0.2"
141
-}
142 143 144 145 146 147 148 149 150
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.
151
isPkgDir :: String -> String -> String -> NoCallStackIO Bool
152
isPkgDir _ _   ('.' : _)  = return False  -- ignore files starting with a .
153 154 155 156 157 158
isPkgDir c dir xs         = do
                              let candidate = dir </> uhcPackageDir xs c
                              -- putStrLn $ "trying: " ++ candidate
                              doesFileExist (candidate </> installedPkgConfig)

parsePackage :: String -> [PackageId]
159
parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x))
160 161 162 163

-- | Create a trivial package info from a directory name.
mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo
mkInstalledPackageInfo p = emptyInstalledPackageInfo
164 165
  { installedUnitId = mkLegacyUnitId p,
    sourcePackageId = p }
Andres Loeh's avatar
Andres Loeh committed
166 167 168 169 170 171 172 173 174


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

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

175
  systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)
176
  userPkgDir   <- getUserPackageDir
177
  let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)
Andres Loeh's avatar
Andres Loeh committed
178 179 180
  let uhcArgs =    -- set package name
                   ["--pkg-build=" ++ display (packageId pkg_descr)]
                   -- common flags lib/exe
181 182
                ++ constructUHCCmdLine userPkgDir systemPkgDir
                                       lbi (libBuildInfo lib) clbi
Andres Loeh's avatar
Andres Loeh committed
183 184 185 186 187
                                       (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))
188
                       (map display (allLibModules lib clbi))
Andres Loeh's avatar
Andres Loeh committed
189 190

  runUhcProg uhcArgs
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
191

Andres Loeh's avatar
Andres Loeh committed
192 193
  return ()

194 195 196
buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
                      -> Executable         -> ComponentLocalBuildInfo -> IO ()
buildExe verbosity _pkg_descr lbi exe clbi = do
197
  systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)
198
  userPkgDir   <- getUserPackageDir
199
  let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)
200 201 202 203 204 205 206 207 208 209
  let uhcArgs =    -- common flags lib/exe
                   constructUHCCmdLine userPkgDir systemPkgDir
                                       lbi (buildInfo exe) clbi
                                       (buildDir lbi) verbosity
                   -- output file
                ++ ["--output", buildDir lbi </> exeName exe]
                   -- main source module
                ++ [modulePath exe]
  runUhcProg uhcArgs

210 211
constructUHCCmdLine :: FilePath -> FilePath
                    -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
Andres Loeh's avatar
Andres Loeh committed
212
                    -> FilePath -> Verbosity -> [String]
213
constructUHCCmdLine user system lbi bi clbi odir verbosity =
Andres Loeh's avatar
Andres Loeh committed
214 215 216 217
     -- verbosity
     (if      verbosity >= deafening then ["-v4"]
      else if verbosity >= normal    then []
      else                                ["-v0"])
218
  ++ hcOptions UHC bi
219
     -- flags for language extensions
220
  ++ languageToFlags   (compiler lbi) (defaultLanguage bi)
221
  ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
Andres Loeh's avatar
Andres Loeh committed
222 223
     -- packages
  ++ ["--hide-all-packages"]
224
  ++ uhcPackageDbOptions user system (withPackageDB lbi)
225
  ++ ["--package=uhcbase"]
Andres Loeh's avatar
Andres Loeh committed
226 227 228 229
  ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ]
     -- search paths
  ++ ["-i" ++ odir]
  ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]
230
  ++ ["-i" ++ autogenComponentModulesDir lbi clbi]
231
  ++ ["-i" ++ autogenPackageModulesDir lbi]
Nick Smallbone's avatar
Nick Smallbone committed
232 233
     -- cpp options
  ++ ["--optP=" ++ opt | opt <- cppOptions bi]
Andres Loeh's avatar
Andres Loeh committed
234 235 236 237 238 239 240
     -- output path
  ++ ["--odir=" ++ odir]
     -- optimization
  ++ (case withOptimization lbi of
        NoOptimisation       ->  ["-O0"]
        NormalOptimisation   ->  ["-O1"]
        MaximumOptimisation  ->  ["-O2"])
241 242 243 244 245 246 247 248

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

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

249
installLib :: Verbosity -> LocalBuildInfo
250
           -> FilePath -> FilePath -> FilePath
251 252
           -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO ()
installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do
253 254
    -- putStrLn $ "dest:  " ++ targetDir
    -- putStrLn $ "built: " ++ builtDir
255
    installDirectoryContents verbosity (builtDir </> display (packageId pkg)) targetDir
256

Ian D. Bollinger's avatar
Ian D. Bollinger committed
257
-- currently hard-coded UHC code generator and variant to use
258
uhcTarget, uhcTargetVariant :: String
259 260 261 262
uhcTarget        = "bc"
uhcTargetVariant = "plain"

-- root directory for a package in UHC
263 264
uhcPackageDir    :: String -> String -> FilePath
uhcPackageSubDir ::           String -> FilePath
265
uhcPackageDir    pkgid compilerid = pkgid </> uhcPackageSubDir compilerid
266
uhcPackageSubDir       compilerid = compilerid </> uhcTarget </> uhcTargetVariant
267 268 269 270 271 272

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

registerPackage
  :: Verbosity
273
  -> Compiler
274
  -> ProgramDb
275
  -> PackageDBStack
276
  -> InstalledPackageInfo
277
  -> IO ()
278
registerPackage verbosity comp progdb packageDbs installedPkgInfo = do
279
    dbdir <- case last packageDbs of
280
      GlobalPackageDB       -> getGlobalPackageDir verbosity progdb
281 282 283
      UserPackageDB         -> getUserPackageDir
      SpecificPackageDB dir -> return dir
    let pkgdir = dbdir </> uhcPackageDir (display pkgid) (display compilerid)
284 285 286 287
    createDirectoryIfMissingVerbose verbosity True pkgdir
    writeUTF8File (pkgdir </> installedPkgConfig)
                  (showInstalledPackageInfo installedPkgInfo)
  where
288
    pkgid      = sourcePackageId installedPkgInfo
289
    compilerid = compilerId comp
290 291 292

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