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