1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE RankNTypes #-}
6
7-----------------------------------------------------------------------------
8-- |
9-- Module      :  Distribution.Simple.InstallDirs
10-- Copyright   :  Isaac Jones 2003-2004
11-- License     :  BSD3
12--
13-- Maintainer  :  cabal-devel@haskell.org
14-- Portability :  portable
15--
16-- This manages everything to do with where files get installed (though does
17-- not get involved with actually doing any installation). It provides an
18-- 'InstallDirs' type which is a set of directories for where to install
19-- things. It also handles the fact that we use templates in these install
20-- dirs. For example most install dirs are relative to some @$prefix@ and by
21-- changing the prefix all other dirs still end up changed appropriately. So it
22-- provides a 'PathTemplate' type and functions for substituting for these
23-- templates.
24
25module Distribution.Simple.InstallDirs (
26        InstallDirs(..),
27        InstallDirTemplates,
28        defaultInstallDirs,
29        defaultInstallDirs',
30        combineInstallDirs,
31        absoluteInstallDirs,
32        CopyDest(..),
33        prefixRelativeInstallDirs,
34        substituteInstallDirTemplates,
35
36        PathTemplate,
37        PathTemplateVariable(..),
38        PathTemplateEnv,
39        toPathTemplate,
40        fromPathTemplate,
41        combinePathTemplate,
42        substPathTemplate,
43        initialPathTemplateEnv,
44        platformTemplateEnv,
45        compilerTemplateEnv,
46        packageTemplateEnv,
47        abiTemplateEnv,
48        installDirsTemplateEnv,
49  ) where
50
51import Prelude ()
52import Distribution.Compat.Prelude
53
54import Distribution.Compat.Environment (lookupEnv)
55import Distribution.Pretty
56import Distribution.Package
57import Distribution.System
58import Distribution.Compiler
59import Distribution.Simple.InstallDirs.Internal
60
61import System.Directory (getAppUserDataDirectory)
62import System.FilePath
63  ( (</>), isPathSeparator
64  , pathSeparator, dropDrive
65  , takeDirectory )
66
67#ifdef mingw32_HOST_OS
68import qualified Prelude
69import Foreign
70import Foreign.C
71#endif
72
73-- ---------------------------------------------------------------------------
74-- Installation directories
75
76
77-- | The directories where we will install files for packages.
78--
79-- We have several different directories for different types of files since
80-- many systems have conventions whereby different types of files in a package
81-- are installed in different directories. This is particularly the case on
82-- Unix style systems.
83--
84data InstallDirs dir = InstallDirs {
85        prefix       :: dir,
86        bindir       :: dir,
87        libdir       :: dir,
88        libsubdir    :: dir,
89        dynlibdir    :: dir,
90        flibdir      :: dir, -- ^ foreign libraries
91        libexecdir   :: dir,
92        libexecsubdir:: dir,
93        includedir   :: dir,
94        datadir      :: dir,
95        datasubdir   :: dir,
96        docdir       :: dir,
97        mandir       :: dir,
98        htmldir      :: dir,
99        haddockdir   :: dir,
100        sysconfdir   :: dir
101    } deriving (Eq, Read, Show, Functor, Generic)
102
103instance Binary dir => Binary (InstallDirs dir)
104
105instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where
106  mempty = gmempty
107  mappend = (<>)
108
109instance Semigroup dir => Semigroup (InstallDirs dir) where
110  (<>) = gmappend
111
112combineInstallDirs :: (a -> b -> c)
113                   -> InstallDirs a
114                   -> InstallDirs b
115                   -> InstallDirs c
116combineInstallDirs combine a b = InstallDirs {
117    prefix       = prefix a     `combine` prefix b,
118    bindir       = bindir a     `combine` bindir b,
119    libdir       = libdir a     `combine` libdir b,
120    libsubdir    = libsubdir a  `combine` libsubdir b,
121    dynlibdir    = dynlibdir a  `combine` dynlibdir b,
122    flibdir      = flibdir a    `combine` flibdir b,
123    libexecdir   = libexecdir a `combine` libexecdir b,
124    libexecsubdir= libexecsubdir a `combine` libexecsubdir b,
125    includedir   = includedir a `combine` includedir b,
126    datadir      = datadir a    `combine` datadir b,
127    datasubdir   = datasubdir a `combine` datasubdir b,
128    docdir       = docdir a     `combine` docdir b,
129    mandir       = mandir a     `combine` mandir b,
130    htmldir      = htmldir a    `combine` htmldir b,
131    haddockdir   = haddockdir a `combine` haddockdir b,
132    sysconfdir   = sysconfdir a `combine` sysconfdir b
133  }
134
135appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a
136appendSubdirs append dirs = dirs {
137    libdir     = libdir dirs `append` libsubdir dirs,
138    libexecdir = libexecdir dirs `append` libexecsubdir dirs,
139    datadir    = datadir dirs `append` datasubdir dirs,
140    libsubdir  = error "internal error InstallDirs.libsubdir",
141    libexecsubdir = error "internal error InstallDirs.libexecsubdir",
142    datasubdir = error "internal error InstallDirs.datasubdir"
143  }
144
145-- | The installation directories in terms of 'PathTemplate's that contain
146-- variables.
147--
148-- The defaults for most of the directories are relative to each other, in
149-- particular they are all relative to a single prefix. This makes it
150-- convenient for the user to override the default installation directory
151-- by only having to specify --prefix=... rather than overriding each
152-- individually. This is done by allowing $-style variables in the dirs.
153-- These are expanded by textual substitution (see 'substPathTemplate').
154--
155-- A few of these installation directories are split into two components, the
156-- dir and subdir. The full installation path is formed by combining the two
157-- together with @\/@. The reason for this is compatibility with other Unix
158-- build systems which also support @--libdir@ and @--datadir@. We would like
159-- users to be able to configure @--libdir=\/usr\/lib64@ for example but
160-- because by default we want to support installing multiple versions of
161-- packages and building the same package for multiple compilers we append the
162-- libsubdir to get: @\/usr\/lib64\/$libname\/$compiler@.
163--
164-- An additional complication is the need to support relocatable packages on
165-- systems which support such things, like Windows.
166--
167type InstallDirTemplates = InstallDirs PathTemplate
168
169-- ---------------------------------------------------------------------------
170-- Default installation directories
171
172defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
173defaultInstallDirs = defaultInstallDirs' False
174
175defaultInstallDirs' :: Bool {- use external internal deps -}
176                    -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
177defaultInstallDirs' True comp userInstall hasLibs = do
178  dflt <- defaultInstallDirs' False comp userInstall hasLibs
179  -- Be a bit more hermetic about per-component installs
180  return dflt { datasubdir = toPathTemplate $ "$abi" </> "$libname",
181                docdir     = toPathTemplate $ "$datadir" </> "doc" </> "$abi" </> "$libname"
182              }
183defaultInstallDirs' False comp userInstall _hasLibs = do
184  installPrefix <-
185      if userInstall
186      then do
187        mDir <- lookupEnv "CABAL_DIR"
188        case mDir of
189          Nothing -> getAppUserDataDirectory "cabal"
190          Just dir -> return dir
191      else case buildOS of
192           Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir
193                         return (windowsProgramFilesDir </> "Haskell")
194           _       -> return "/usr/local"
195  installLibDir <-
196      case buildOS of
197      Windows -> return "$prefix"
198      _       -> return ("$prefix" </> "lib")
199  return $ fmap toPathTemplate $ InstallDirs {
200      prefix       = installPrefix,
201      bindir       = "$prefix" </> "bin",
202      libdir       = installLibDir,
203      libsubdir    = case comp of
204           UHC    -> "$pkgid"
205           _other -> "$abi" </> "$libname",
206      dynlibdir    = "$libdir" </> case comp of
207           UHC    -> "$pkgid"
208           _other -> "$abi",
209      libexecsubdir= "$abi" </> "$pkgid",
210      flibdir      = "$libdir",
211      libexecdir   = case buildOS of
212        Windows   -> "$prefix" </> "$libname"
213        _other    -> "$prefix" </> "libexec",
214      includedir   = "$libdir" </> "$libsubdir" </> "include",
215      datadir      = case buildOS of
216        Windows   -> "$prefix"
217        _other    -> "$prefix" </> "share",
218      datasubdir   = "$abi" </> "$pkgid",
219      docdir       = "$datadir" </> "doc" </> "$abi" </> "$pkgid",
220      mandir       = "$datadir" </> "man",
221      htmldir      = "$docdir"  </> "html",
222      haddockdir   = "$htmldir",
223      sysconfdir   = "$prefix" </> "etc"
224  }
225
226-- ---------------------------------------------------------------------------
227-- Converting directories, absolute or prefix-relative
228
229-- | Substitute the install dir templates into each other.
230--
231-- To prevent cyclic substitutions, only some variables are allowed in
232-- particular dir templates. If out of scope vars are present, they are not
233-- substituted for. Checking for any remaining unsubstituted vars can be done
234-- as a subsequent operation.
235--
236-- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we
237-- can replace 'prefix' with the 'PrefixVar' and get resulting
238-- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it
239-- each to check which paths are relative to the $prefix.
240--
241substituteInstallDirTemplates :: PathTemplateEnv
242                              -> InstallDirTemplates -> InstallDirTemplates
243substituteInstallDirTemplates env dirs = dirs'
244  where
245    dirs' = InstallDirs {
246      -- So this specifies exactly which vars are allowed in each template
247      prefix     = subst prefix     [],
248      bindir     = subst bindir     [prefixVar],
249      libdir     = subst libdir     [prefixVar, bindirVar],
250      libsubdir  = subst libsubdir  [],
251      dynlibdir  = subst dynlibdir  [prefixVar, bindirVar, libdirVar],
252      flibdir    = subst flibdir    [prefixVar, bindirVar, libdirVar],
253      libexecdir = subst libexecdir prefixBinLibVars,
254      libexecsubdir = subst libexecsubdir [],
255      includedir = subst includedir prefixBinLibVars,
256      datadir    = subst datadir    prefixBinLibVars,
257      datasubdir = subst datasubdir [],
258      docdir     = subst docdir     prefixBinLibDataVars,
259      mandir     = subst mandir     (prefixBinLibDataVars ++ [docdirVar]),
260      htmldir    = subst htmldir    (prefixBinLibDataVars ++ [docdirVar]),
261      haddockdir = subst haddockdir (prefixBinLibDataVars ++
262                                      [docdirVar, htmldirVar]),
263      sysconfdir = subst sysconfdir prefixBinLibVars
264    }
265    subst dir env' = substPathTemplate (env'++env) (dir dirs)
266
267    prefixVar        = (PrefixVar,     prefix     dirs')
268    bindirVar        = (BindirVar,     bindir     dirs')
269    libdirVar        = (LibdirVar,     libdir     dirs')
270    libsubdirVar     = (LibsubdirVar,  libsubdir  dirs')
271    datadirVar       = (DatadirVar,    datadir    dirs')
272    datasubdirVar    = (DatasubdirVar, datasubdir dirs')
273    docdirVar        = (DocdirVar,     docdir     dirs')
274    htmldirVar       = (HtmldirVar,    htmldir    dirs')
275    prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar]
276    prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar]
277
278-- | Convert from abstract install directories to actual absolute ones by
279-- substituting for all the variables in the abstract paths, to get real
280-- absolute path.
281absoluteInstallDirs :: PackageIdentifier
282                    -> UnitId
283                    -> CompilerInfo
284                    -> CopyDest
285                    -> Platform
286                    -> InstallDirs PathTemplate
287                    -> InstallDirs FilePath
288absoluteInstallDirs pkgId libname compilerId copydest platform dirs =
289    (case copydest of
290       CopyTo destdir -> fmap ((destdir </>) . dropDrive)
291       CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir))
292       _              -> id)
293  . appendSubdirs (</>)
294  . fmap fromPathTemplate
295  $ substituteInstallDirTemplates env dirs
296  where
297    env = initialPathTemplateEnv pkgId libname compilerId platform
298    substPrefix pre root path
299      | pre `isPrefixOf` path = root ++ drop (length pre) path
300      | otherwise             = path
301
302
303-- |The location prefix for the /copy/ command.
304data CopyDest
305  = NoCopyDest
306  | CopyTo FilePath
307  | CopyToDb FilePath
308  -- ^ when using the ${pkgroot} as prefix. The CopyToDb will
309  --   adjust the paths to be relative to the provided package
310  --   database when copying / installing.
311  deriving (Eq, Show, Generic)
312
313instance Binary CopyDest
314
315-- | Check which of the paths are relative to the installation $prefix.
316--
317-- If any of the paths are not relative, ie they are absolute paths, then it
318-- prevents us from making a relocatable package (also known as a \"prefix
319-- independent\" package).
320--
321prefixRelativeInstallDirs :: PackageIdentifier
322                          -> UnitId
323                          -> CompilerInfo
324                          -> Platform
325                          -> InstallDirTemplates
326                          -> InstallDirs (Maybe FilePath)
327prefixRelativeInstallDirs pkgId libname compilerId platform dirs =
328    fmap relative
329  . appendSubdirs combinePathTemplate
330  $ -- substitute the path template into each other, except that we map
331    -- \$prefix back to $prefix. We're trying to end up with templates that
332    -- mention no vars except $prefix.
333    substituteInstallDirTemplates env dirs {
334      prefix = PathTemplate [Variable PrefixVar]
335    }
336  where
337    env = initialPathTemplateEnv pkgId libname compilerId platform
338
339    -- If it starts with $prefix then it's relative and produce the relative
340    -- path by stripping off $prefix/ or $prefix
341    relative dir = case dir of
342      PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs)
343    relative' (Variable PrefixVar : Ordinary (s:rest) : rest')
344                      | isPathSeparator s = Just (Ordinary rest : rest')
345    relative' (Variable PrefixVar : rest) = Just rest
346    relative' _                           = Nothing
347
348-- ---------------------------------------------------------------------------
349-- Path templates
350
351-- | An abstract path, possibly containing variables that need to be
352-- substituted for to get a real 'FilePath'.
353--
354newtype PathTemplate = PathTemplate [PathComponent]
355  deriving (Eq, Ord, Generic)
356
357instance Binary PathTemplate
358
359type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]
360
361-- | Convert a 'FilePath' to a 'PathTemplate' including any template vars.
362--
363toPathTemplate :: FilePath -> PathTemplate
364toPathTemplate fp = PathTemplate
365    . fromMaybe (error $ "panic! toPathTemplate " ++ show fp)
366    . readMaybe -- TODO: eradicateNoParse
367    $ fp
368
369-- | Convert back to a path, any remaining vars are included
370--
371fromPathTemplate :: PathTemplate -> FilePath
372fromPathTemplate (PathTemplate template) = show template
373
374combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate
375combinePathTemplate (PathTemplate t1) (PathTemplate t2) =
376  PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2)
377
378substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate
379substPathTemplate environment (PathTemplate template) =
380    PathTemplate (concatMap subst template)
381
382    where subst component@(Ordinary _) = [component]
383          subst component@(Variable variable) =
384              case lookup variable environment of
385                  Just (PathTemplate components) -> components
386                  Nothing                        -> [component]
387
388-- | The initial environment has all the static stuff but no paths
389initialPathTemplateEnv :: PackageIdentifier
390                       -> UnitId
391                       -> CompilerInfo
392                       -> Platform
393                       -> PathTemplateEnv
394initialPathTemplateEnv pkgId libname compiler platform =
395     packageTemplateEnv  pkgId libname
396  ++ compilerTemplateEnv compiler
397  ++ platformTemplateEnv platform
398  ++ abiTemplateEnv compiler platform
399
400packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv
401packageTemplateEnv pkgId uid =
402  [(PkgNameVar,  PathTemplate [Ordinary $ prettyShow (packageName pkgId)])
403  ,(PkgVerVar,   PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)])
404  -- Invariant: uid is actually a HashedUnitId.  Hard to enforce because
405  -- it's an API change.
406  ,(LibNameVar,  PathTemplate [Ordinary $ prettyShow uid])
407  ,(PkgIdVar,    PathTemplate [Ordinary $ prettyShow pkgId])
408  ]
409
410compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv
411compilerTemplateEnv compiler =
412  [(CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)])
413  ]
414
415platformTemplateEnv :: Platform -> PathTemplateEnv
416platformTemplateEnv (Platform arch os) =
417  [(OSVar,       PathTemplate [Ordinary $ prettyShow os])
418  ,(ArchVar,     PathTemplate [Ordinary $ prettyShow arch])
419  ]
420
421abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv
422abiTemplateEnv compiler (Platform arch os) =
423  [(AbiVar,      PathTemplate [Ordinary $ prettyShow arch ++ '-':prettyShow os ++
424                                          '-':prettyShow (compilerInfoId compiler) ++
425                                          case compilerInfoAbiTag compiler of
426                                            NoAbiTag   -> ""
427                                            AbiTag tag -> '-':tag])
428  ,(AbiTagVar,   PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)])
429  ]
430
431installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv
432installDirsTemplateEnv dirs =
433  [(PrefixVar,     prefix     dirs)
434  ,(BindirVar,     bindir     dirs)
435  ,(LibdirVar,     libdir     dirs)
436  ,(LibsubdirVar,  libsubdir  dirs)
437  ,(DynlibdirVar,  dynlibdir  dirs)
438  ,(DatadirVar,    datadir    dirs)
439  ,(DatasubdirVar, datasubdir dirs)
440  ,(DocdirVar,     docdir     dirs)
441  ,(HtmldirVar,    htmldir    dirs)
442  ]
443
444
445-- ---------------------------------------------------------------------------
446-- Parsing and showing path templates:
447
448-- The textual format is that of an ordinary Haskell String, eg
449-- "$prefix/bin"
450-- and this gets parsed to the internal representation as a sequence of path
451-- spans which are either strings or variables, eg:
452-- PathTemplate [Variable PrefixVar, Ordinary "/bin" ]
453
454instance Show PathTemplate where
455  show (PathTemplate template) = show (show template)
456
457instance Read PathTemplate where
458  readsPrec p s = [ (PathTemplate template, s')
459                  | (path, s')     <- readsPrec p s
460                  , (template, "") <- reads path ]
461
462-- ---------------------------------------------------------------------------
463-- Internal utilities
464
465getWindowsProgramFilesDir :: NoCallStackIO FilePath
466getWindowsProgramFilesDir = do
467#ifdef mingw32_HOST_OS
468  m <- shGetFolderPath csidl_PROGRAM_FILES
469#else
470  let m = Nothing
471#endif
472  return (fromMaybe "C:\\Program Files" m)
473
474#ifdef mingw32_HOST_OS
475shGetFolderPath :: CInt -> NoCallStackIO (Maybe FilePath)
476shGetFolderPath n =
477  allocaArray long_path_size $ \pPath -> do
478     r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath
479     if (r /= 0)
480        then return Nothing
481        else do s <- peekCWString pPath; return (Just s)
482  where
483    long_path_size      = 1024 -- MAX_PATH is 260, this should be plenty
484
485csidl_PROGRAM_FILES :: CInt
486csidl_PROGRAM_FILES = 0x0026
487-- csidl_PROGRAM_FILES_COMMON :: CInt
488-- csidl_PROGRAM_FILES_COMMON = 0x002b
489
490#ifdef x86_64_HOST_ARCH
491#define CALLCONV ccall
492#else
493#define CALLCONV stdcall
494#endif
495
496foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW"
497            c_SHGetFolderPath :: Ptr ()
498                              -> CInt
499                              -> Ptr ()
500                              -> CInt
501                              -> CWString
502                              -> Prelude.IO CInt
503#endif
504