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