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