{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.InstallDirs
-- Copyright   :  Isaac Jones 2003-2004
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This manages everything to do with where files get installed (though does
-- not get involved with actually doing any installation). It provides an
-- 'InstallDirs' type which is a set of directories for where to install
-- things. It also handles the fact that we use templates in these install
-- dirs. For example most install dirs are relative to some @$prefix@ and by
-- changing the prefix all other dirs still end up changed appropriately. So it
-- provides a 'PathTemplate' type and functions for substituting for these
-- templates.

module Distribution.Simple.InstallDirs (
        InstallDirs(..),
        InstallDirTemplates,
        defaultInstallDirs,
        defaultInstallDirs',
        combineInstallDirs,
        absoluteInstallDirs,
        CopyDest(..),
        prefixRelativeInstallDirs,
        substituteInstallDirTemplates,

        PathTemplate,
        PathTemplateVariable(..),
        PathTemplateEnv,
        toPathTemplate,
        fromPathTemplate,
        combinePathTemplate,
        substPathTemplate,
        initialPathTemplateEnv,
        platformTemplateEnv,
        compilerTemplateEnv,
        packageTemplateEnv,
        abiTemplateEnv,
        installDirsTemplateEnv,
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Compat.Environment (lookupEnv)
import Distribution.Pretty
import Distribution.Package
import Distribution.System
import Distribution.Compiler
import Distribution.Simple.InstallDirs.Internal

import System.Directory (getAppUserDataDirectory)
import System.FilePath
  ( (</>), isPathSeparator
  , pathSeparator, dropDrive
  , takeDirectory )

#ifdef mingw32_HOST_OS
import qualified Prelude
import Foreign
import Foreign.C
#endif

-- ---------------------------------------------------------------------------
-- Installation directories


-- | The directories where we will install files for packages.
--
-- We have several different directories for different types of files since
-- many systems have conventions whereby different types of files in a package
-- are installed in different directories. This is particularly the case on
-- Unix style systems.
--
data InstallDirs dir = InstallDirs {
        InstallDirs dir -> dir
prefix       :: dir,
        InstallDirs dir -> dir
bindir       :: dir,
        InstallDirs dir -> dir
libdir       :: dir,
        InstallDirs dir -> dir
libsubdir    :: dir,
        InstallDirs dir -> dir
dynlibdir    :: dir,
        InstallDirs dir -> dir
flibdir      :: dir, -- ^ foreign libraries
        InstallDirs dir -> dir
libexecdir   :: dir,
        InstallDirs dir -> dir
libexecsubdir:: dir,
        InstallDirs dir -> dir
includedir   :: dir,
        InstallDirs dir -> dir
datadir      :: dir,
        InstallDirs dir -> dir
datasubdir   :: dir,
        InstallDirs dir -> dir
docdir       :: dir,
        InstallDirs dir -> dir
mandir       :: dir,
        InstallDirs dir -> dir
htmldir      :: dir,
        InstallDirs dir -> dir
haddockdir   :: dir,
        InstallDirs dir -> dir
sysconfdir   :: dir
    } deriving (InstallDirs dir -> InstallDirs dir -> Bool
(InstallDirs dir -> InstallDirs dir -> Bool)
-> (InstallDirs dir -> InstallDirs dir -> Bool)
-> Eq (InstallDirs dir)
forall dir. Eq dir => InstallDirs dir -> InstallDirs dir -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InstallDirs dir -> InstallDirs dir -> Bool
$c/= :: forall dir. Eq dir => InstallDirs dir -> InstallDirs dir -> Bool
== :: InstallDirs dir -> InstallDirs dir -> Bool
$c== :: forall dir. Eq dir => InstallDirs dir -> InstallDirs dir -> Bool
Eq, ReadPrec [InstallDirs dir]
ReadPrec (InstallDirs dir)
Int -> ReadS (InstallDirs dir)
ReadS [InstallDirs dir]
(Int -> ReadS (InstallDirs dir))
-> ReadS [InstallDirs dir]
-> ReadPrec (InstallDirs dir)
-> ReadPrec [InstallDirs dir]
-> Read (InstallDirs dir)
forall dir. Read dir => ReadPrec [InstallDirs dir]
forall dir. Read dir => ReadPrec (InstallDirs dir)
forall dir. Read dir => Int -> ReadS (InstallDirs dir)
forall dir. Read dir => ReadS [InstallDirs dir]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [InstallDirs dir]
$creadListPrec :: forall dir. Read dir => ReadPrec [InstallDirs dir]
readPrec :: ReadPrec (InstallDirs dir)
$creadPrec :: forall dir. Read dir => ReadPrec (InstallDirs dir)
readList :: ReadS [InstallDirs dir]
$creadList :: forall dir. Read dir => ReadS [InstallDirs dir]
readsPrec :: Int -> ReadS (InstallDirs dir)
$creadsPrec :: forall dir. Read dir => Int -> ReadS (InstallDirs dir)
Read, Int -> InstallDirs dir -> ShowS
[InstallDirs dir] -> ShowS
InstallDirs dir -> String
(Int -> InstallDirs dir -> ShowS)
-> (InstallDirs dir -> String)
-> ([InstallDirs dir] -> ShowS)
-> Show (InstallDirs dir)
forall dir. Show dir => Int -> InstallDirs dir -> ShowS
forall dir. Show dir => [InstallDirs dir] -> ShowS
forall dir. Show dir => InstallDirs dir -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InstallDirs dir] -> ShowS
$cshowList :: forall dir. Show dir => [InstallDirs dir] -> ShowS
show :: InstallDirs dir -> String
$cshow :: forall dir. Show dir => InstallDirs dir -> String
showsPrec :: Int -> InstallDirs dir -> ShowS
$cshowsPrec :: forall dir. Show dir => Int -> InstallDirs dir -> ShowS
Show, a -> InstallDirs b -> InstallDirs a
(a -> b) -> InstallDirs a -> InstallDirs b
(forall a b. (a -> b) -> InstallDirs a -> InstallDirs b)
-> (forall a b. a -> InstallDirs b -> InstallDirs a)
-> Functor InstallDirs
forall a b. a -> InstallDirs b -> InstallDirs a
forall a b. (a -> b) -> InstallDirs a -> InstallDirs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> InstallDirs b -> InstallDirs a
$c<$ :: forall a b. a -> InstallDirs b -> InstallDirs a
fmap :: (a -> b) -> InstallDirs a -> InstallDirs b
$cfmap :: forall a b. (a -> b) -> InstallDirs a -> InstallDirs b
Functor, (forall x. InstallDirs dir -> Rep (InstallDirs dir) x)
-> (forall x. Rep (InstallDirs dir) x -> InstallDirs dir)
-> Generic (InstallDirs dir)
forall x. Rep (InstallDirs dir) x -> InstallDirs dir
forall x. InstallDirs dir -> Rep (InstallDirs dir) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall dir x. Rep (InstallDirs dir) x -> InstallDirs dir
forall dir x. InstallDirs dir -> Rep (InstallDirs dir) x
$cto :: forall dir x. Rep (InstallDirs dir) x -> InstallDirs dir
$cfrom :: forall dir x. InstallDirs dir -> Rep (InstallDirs dir) x
Generic, Typeable)

instance Binary dir => Binary (InstallDirs dir)
instance Structured dir => Structured (InstallDirs dir)

instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where
  mempty :: InstallDirs dir
mempty = InstallDirs dir
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
  mappend :: InstallDirs dir -> InstallDirs dir -> InstallDirs dir
mappend = InstallDirs dir -> InstallDirs dir -> InstallDirs dir
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup dir => Semigroup (InstallDirs dir) where
  <> :: InstallDirs dir -> InstallDirs dir -> InstallDirs dir
(<>) = InstallDirs dir -> InstallDirs dir -> InstallDirs dir
forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend

combineInstallDirs :: (a -> b -> c)
                   -> InstallDirs a
                   -> InstallDirs b
                   -> InstallDirs c
combineInstallDirs :: (a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c
combineInstallDirs a -> b -> c
combine InstallDirs a
a InstallDirs b
b = InstallDirs :: forall dir.
dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> InstallDirs dir
InstallDirs {
    prefix :: c
prefix       = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
prefix InstallDirs a
a     a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
prefix InstallDirs b
b,
    bindir :: c
bindir       = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
bindir InstallDirs a
a     a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
bindir InstallDirs b
b,
    libdir :: c
libdir       = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
libdir InstallDirs a
a     a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
libdir InstallDirs b
b,
    libsubdir :: c
libsubdir    = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
libsubdir InstallDirs a
a  a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
libsubdir InstallDirs b
b,
    dynlibdir :: c
dynlibdir    = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
dynlibdir InstallDirs a
a  a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
dynlibdir InstallDirs b
b,
    flibdir :: c
flibdir      = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
flibdir InstallDirs a
a    a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
flibdir InstallDirs b
b,
    libexecdir :: c
libexecdir   = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
libexecdir InstallDirs a
a a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
libexecdir InstallDirs b
b,
    libexecsubdir :: c
libexecsubdir= InstallDirs a -> a
forall dir. InstallDirs dir -> dir
libexecsubdir InstallDirs a
a a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
libexecsubdir InstallDirs b
b,
    includedir :: c
includedir   = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
includedir InstallDirs a
a a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
includedir InstallDirs b
b,
    datadir :: c
datadir      = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
datadir InstallDirs a
a    a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
datadir InstallDirs b
b,
    datasubdir :: c
datasubdir   = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
datasubdir InstallDirs a
a a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
datasubdir InstallDirs b
b,
    docdir :: c
docdir       = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
docdir InstallDirs a
a     a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
docdir InstallDirs b
b,
    mandir :: c
mandir       = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
mandir InstallDirs a
a     a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
mandir InstallDirs b
b,
    htmldir :: c
htmldir      = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
htmldir InstallDirs a
a    a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
htmldir InstallDirs b
b,
    haddockdir :: c
haddockdir   = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
haddockdir InstallDirs a
a a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
haddockdir InstallDirs b
b,
    sysconfdir :: c
sysconfdir   = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
sysconfdir InstallDirs a
a a -> b -> c
`combine` InstallDirs b -> b
forall dir. InstallDirs dir -> dir
sysconfdir InstallDirs b
b
  }

appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a
appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a
appendSubdirs a -> a -> a
append InstallDirs a
dirs = InstallDirs a
dirs {
    libdir :: a
libdir     = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
libdir InstallDirs a
dirs a -> a -> a
`append` InstallDirs a -> a
forall dir. InstallDirs dir -> dir
libsubdir InstallDirs a
dirs,
    libexecdir :: a
libexecdir = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
libexecdir InstallDirs a
dirs a -> a -> a
`append` InstallDirs a -> a
forall dir. InstallDirs dir -> dir
libexecsubdir InstallDirs a
dirs,
    datadir :: a
datadir    = InstallDirs a -> a
forall dir. InstallDirs dir -> dir
datadir InstallDirs a
dirs a -> a -> a
`append` InstallDirs a -> a
forall dir. InstallDirs dir -> dir
datasubdir InstallDirs a
dirs,
    libsubdir :: a
libsubdir  = String -> a
forall a. HasCallStack => String -> a
error String
"internal error InstallDirs.libsubdir",
    libexecsubdir :: a
libexecsubdir = String -> a
forall a. HasCallStack => String -> a
error String
"internal error InstallDirs.libexecsubdir",
    datasubdir :: a
datasubdir = String -> a
forall a. HasCallStack => String -> a
error String
"internal error InstallDirs.datasubdir"
  }

-- | The installation directories in terms of 'PathTemplate's that contain
-- variables.
--
-- The defaults for most of the directories are relative to each other, in
-- particular they are all relative to a single prefix. This makes it
-- convenient for the user to override the default installation directory
-- by only having to specify --prefix=... rather than overriding each
-- individually. This is done by allowing $-style variables in the dirs.
-- These are expanded by textual substitution (see 'substPathTemplate').
--
-- A few of these installation directories are split into two components, the
-- dir and subdir. The full installation path is formed by combining the two
-- together with @\/@. The reason for this is compatibility with other Unix
-- build systems which also support @--libdir@ and @--datadir@. We would like
-- users to be able to configure @--libdir=\/usr\/lib64@ for example but
-- because by default we want to support installing multiple versions of
-- packages and building the same package for multiple compilers we append the
-- libsubdir to get: @\/usr\/lib64\/$libname\/$compiler@.
--
-- An additional complication is the need to support relocatable packages on
-- systems which support such things, like Windows.
--
type InstallDirTemplates = InstallDirs PathTemplate

-- ---------------------------------------------------------------------------
-- Default installation directories

defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
defaultInstallDirs = Bool -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
defaultInstallDirs' Bool
False

defaultInstallDirs' :: Bool {- use external internal deps -}
                    -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
defaultInstallDirs' :: Bool -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
defaultInstallDirs' Bool
True CompilerFlavor
comp Bool
userInstall Bool
hasLibs = do
  InstallDirTemplates
dflt <- Bool -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
defaultInstallDirs' Bool
False CompilerFlavor
comp Bool
userInstall Bool
hasLibs
  -- Be a bit more hermetic about per-component installs
  InstallDirTemplates -> IO InstallDirTemplates
forall (m :: * -> *) a. Monad m => a -> m a
return InstallDirTemplates
dflt { datasubdir :: PathTemplate
datasubdir = String -> PathTemplate
toPathTemplate (String -> PathTemplate) -> String -> PathTemplate
forall a b. (a -> b) -> a -> b
$ String
"$abi" String -> ShowS
</> String
"$libname",
                docdir :: PathTemplate
docdir     = String -> PathTemplate
toPathTemplate (String -> PathTemplate) -> String -> PathTemplate
forall a b. (a -> b) -> a -> b
$ String
"$datadir" String -> ShowS
</> String
"doc" String -> ShowS
</> String
"$abi" String -> ShowS
</> String
"$libname"
              }
defaultInstallDirs' Bool
False CompilerFlavor
comp Bool
userInstall Bool
_hasLibs = do
  String
installPrefix <-
      if Bool
userInstall
      then do
        Maybe String
mDir <- String -> IO (Maybe String)
lookupEnv String
"CABAL_DIR"
        case Maybe String
mDir of
          Maybe String
Nothing -> String -> IO String
getAppUserDataDirectory String
"cabal"
          Just String
dir -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
dir
      else case OS
buildOS of
           OS
Windows -> do String
windowsProgramFilesDir <- IO String
getWindowsProgramFilesDir
                         String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
windowsProgramFilesDir String -> ShowS
</> String
"Haskell")
           OS
_       -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"/usr/local"
  String
installLibDir <-
      case OS
buildOS of
      OS
Windows -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"$prefix"
      OS
_       -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"$prefix" String -> ShowS
</> String
"lib")
  InstallDirTemplates -> IO InstallDirTemplates
forall (m :: * -> *) a. Monad m => a -> m a
return (InstallDirTemplates -> IO InstallDirTemplates)
-> InstallDirTemplates -> IO InstallDirTemplates
forall a b. (a -> b) -> a -> b
$ (String -> PathTemplate)
-> InstallDirs String -> InstallDirTemplates
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> PathTemplate
toPathTemplate (InstallDirs String -> InstallDirTemplates)
-> InstallDirs String -> InstallDirTemplates
forall a b. (a -> b) -> a -> b
$ InstallDirs :: forall dir.
dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> InstallDirs dir
InstallDirs {
      prefix :: String
prefix       = String
installPrefix,
      bindir :: String
bindir       = String
"$prefix" String -> ShowS
</> String
"bin",
      libdir :: String
libdir       = String
installLibDir,
      libsubdir :: String
libsubdir    = case CompilerFlavor
comp of
           CompilerFlavor
UHC    -> String
"$pkgid"
           CompilerFlavor
_other -> String
"$abi" String -> ShowS
</> String
"$libname",
      dynlibdir :: String
dynlibdir    = String
"$libdir" String -> ShowS
</> case CompilerFlavor
comp of
           CompilerFlavor
UHC    -> String
"$pkgid"
           CompilerFlavor
_other -> String
"$abi",
      libexecsubdir :: String
libexecsubdir= String
"$abi" String -> ShowS
</> String
"$pkgid",
      flibdir :: String
flibdir      = String
"$libdir",
      libexecdir :: String
libexecdir   = case OS
buildOS of
        OS
Windows   -> String
"$prefix" String -> ShowS
</> String
"$libname"
        OS
_other    -> String
"$prefix" String -> ShowS
</> String
"libexec",
      includedir :: String
includedir   = String
"$libdir" String -> ShowS
</> String
"$libsubdir" String -> ShowS
</> String
"include",
      datadir :: String
datadir      = case OS
buildOS of
        OS
Windows   -> String
"$prefix"
        OS
_other    -> String
"$prefix" String -> ShowS
</> String
"share",
      datasubdir :: String
datasubdir   = String
"$abi" String -> ShowS
</> String
"$pkgid",
      docdir :: String
docdir       = String
"$datadir" String -> ShowS
</> String
"doc" String -> ShowS
</> String
"$abi" String -> ShowS
</> String
"$pkgid",
      mandir :: String
mandir       = String
"$datadir" String -> ShowS
</> String
"man",
      htmldir :: String
htmldir      = String
"$docdir"  String -> ShowS
</> String
"html",
      haddockdir :: String
haddockdir   = String
"$htmldir",
      sysconfdir :: String
sysconfdir   = String
"$prefix" String -> ShowS
</> String
"etc"
  }

-- ---------------------------------------------------------------------------
-- Converting directories, absolute or prefix-relative

-- | Substitute the install dir templates into each other.
--
-- To prevent cyclic substitutions, only some variables are allowed in
-- particular dir templates. If out of scope vars are present, they are not
-- substituted for. Checking for any remaining unsubstituted vars can be done
-- as a subsequent operation.
--
-- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we
-- can replace 'prefix' with the 'PrefixVar' and get resulting
-- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it
-- each to check which paths are relative to the $prefix.
--
substituteInstallDirTemplates :: PathTemplateEnv
                              -> InstallDirTemplates -> InstallDirTemplates
substituteInstallDirTemplates :: PathTemplateEnv -> InstallDirTemplates -> InstallDirTemplates
substituteInstallDirTemplates PathTemplateEnv
env InstallDirTemplates
dirs = InstallDirTemplates
dirs'
  where
    dirs' :: InstallDirTemplates
dirs' = InstallDirs :: forall dir.
dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> dir
-> InstallDirs dir
InstallDirs {
      -- So this specifies exactly which vars are allowed in each template
      prefix :: PathTemplate
prefix     = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
prefix     [],
      bindir :: PathTemplate
bindir     = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
bindir     [(PathTemplateVariable, PathTemplate)
prefixVar],
      libdir :: PathTemplate
libdir     = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
libdir     [(PathTemplateVariable, PathTemplate)
prefixVar, (PathTemplateVariable, PathTemplate)
bindirVar],
      libsubdir :: PathTemplate
libsubdir  = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
libsubdir  [],
      dynlibdir :: PathTemplate
dynlibdir  = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
dynlibdir  [(PathTemplateVariable, PathTemplate)
prefixVar, (PathTemplateVariable, PathTemplate)
bindirVar, (PathTemplateVariable, PathTemplate)
libdirVar],
      flibdir :: PathTemplate
flibdir    = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
flibdir    [(PathTemplateVariable, PathTemplate)
prefixVar, (PathTemplateVariable, PathTemplate)
bindirVar, (PathTemplateVariable, PathTemplate)
libdirVar],
      libexecdir :: PathTemplate
libexecdir = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
libexecdir PathTemplateEnv
prefixBinLibVars,
      libexecsubdir :: PathTemplate
libexecsubdir = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
libexecsubdir [],
      includedir :: PathTemplate
includedir = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
includedir PathTemplateEnv
prefixBinLibVars,
      datadir :: PathTemplate
datadir    = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
datadir    PathTemplateEnv
prefixBinLibVars,
      datasubdir :: PathTemplate
datasubdir = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
datasubdir [],
      docdir :: PathTemplate
docdir     = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
docdir     PathTemplateEnv
prefixBinLibDataVars,
      mandir :: PathTemplate
mandir     = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
mandir     (PathTemplateEnv
prefixBinLibDataVars PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ [(PathTemplateVariable, PathTemplate)
docdirVar]),
      htmldir :: PathTemplate
htmldir    = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
htmldir    (PathTemplateEnv
prefixBinLibDataVars PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ [(PathTemplateVariable, PathTemplate)
docdirVar]),
      haddockdir :: PathTemplate
haddockdir = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
haddockdir (PathTemplateEnv
prefixBinLibDataVars PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++
                                      [(PathTemplateVariable, PathTemplate)
docdirVar, (PathTemplateVariable, PathTemplate)
htmldirVar]),
      sysconfdir :: PathTemplate
sysconfdir = (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
sysconfdir PathTemplateEnv
prefixBinLibVars
    }
    subst :: (InstallDirTemplates -> PathTemplate)
-> PathTemplateEnv -> PathTemplate
subst InstallDirTemplates -> PathTemplate
dir PathTemplateEnv
env' = PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate (PathTemplateEnv
env'PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++PathTemplateEnv
env) (InstallDirTemplates -> PathTemplate
dir InstallDirTemplates
dirs)

    prefixVar :: (PathTemplateVariable, PathTemplate)
prefixVar        = (PathTemplateVariable
PrefixVar,     InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
prefix     InstallDirTemplates
dirs')
    bindirVar :: (PathTemplateVariable, PathTemplate)
bindirVar        = (PathTemplateVariable
BindirVar,     InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
bindir     InstallDirTemplates
dirs')
    libdirVar :: (PathTemplateVariable, PathTemplate)
libdirVar        = (PathTemplateVariable
LibdirVar,     InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
libdir     InstallDirTemplates
dirs')
    libsubdirVar :: (PathTemplateVariable, PathTemplate)
libsubdirVar     = (PathTemplateVariable
LibsubdirVar,  InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
libsubdir  InstallDirTemplates
dirs')
    datadirVar :: (PathTemplateVariable, PathTemplate)
datadirVar       = (PathTemplateVariable
DatadirVar,    InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
datadir    InstallDirTemplates
dirs')
    datasubdirVar :: (PathTemplateVariable, PathTemplate)
datasubdirVar    = (PathTemplateVariable
DatasubdirVar, InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
datasubdir InstallDirTemplates
dirs')
    docdirVar :: (PathTemplateVariable, PathTemplate)
docdirVar        = (PathTemplateVariable
DocdirVar,     InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
docdir     InstallDirTemplates
dirs')
    htmldirVar :: (PathTemplateVariable, PathTemplate)
htmldirVar       = (PathTemplateVariable
HtmldirVar,    InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
htmldir    InstallDirTemplates
dirs')
    prefixBinLibVars :: PathTemplateEnv
prefixBinLibVars = [(PathTemplateVariable, PathTemplate)
prefixVar, (PathTemplateVariable, PathTemplate)
bindirVar, (PathTemplateVariable, PathTemplate)
libdirVar, (PathTemplateVariable, PathTemplate)
libsubdirVar]
    prefixBinLibDataVars :: PathTemplateEnv
prefixBinLibDataVars = PathTemplateEnv
prefixBinLibVars PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ [(PathTemplateVariable, PathTemplate)
datadirVar, (PathTemplateVariable, PathTemplate)
datasubdirVar]

-- | Convert from abstract install directories to actual absolute ones by
-- substituting for all the variables in the abstract paths, to get real
-- absolute path.
absoluteInstallDirs :: PackageIdentifier
                    -> UnitId
                    -> CompilerInfo
                    -> CopyDest
                    -> Platform
                    -> InstallDirs PathTemplate
                    -> InstallDirs FilePath
absoluteInstallDirs :: PackageIdentifier
-> UnitId
-> CompilerInfo
-> CopyDest
-> Platform
-> InstallDirTemplates
-> InstallDirs String
absoluteInstallDirs PackageIdentifier
pkgId UnitId
libname CompilerInfo
compilerId CopyDest
copydest Platform
platform InstallDirTemplates
dirs =
    (case CopyDest
copydest of
       CopyTo String
destdir -> ShowS -> InstallDirs String -> InstallDirs String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String
destdir String -> ShowS
</>) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropDrive)
       CopyToDb String
dbdir -> ShowS -> InstallDirs String -> InstallDirs String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> ShowS
forall a. Eq a => [a] -> [a] -> [a] -> [a]
substPrefix String
"${pkgroot}" (ShowS
takeDirectory String
dbdir))
       CopyDest
_              -> InstallDirs String -> InstallDirs String
forall a. a -> a
id)
  (InstallDirs String -> InstallDirs String)
-> (InstallDirTemplates -> InstallDirs String)
-> InstallDirTemplates
-> InstallDirs String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS) -> InstallDirs String -> InstallDirs String
forall a. (a -> a -> a) -> InstallDirs a -> InstallDirs a
appendSubdirs String -> ShowS
(</>)
  (InstallDirs String -> InstallDirs String)
-> (InstallDirTemplates -> InstallDirs String)
-> InstallDirTemplates
-> InstallDirs String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathTemplate -> String)
-> InstallDirTemplates -> InstallDirs String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> String
fromPathTemplate
  (InstallDirTemplates -> InstallDirs String)
-> InstallDirTemplates -> InstallDirs String
forall a b. (a -> b) -> a -> b
$ PathTemplateEnv -> InstallDirTemplates -> InstallDirTemplates
substituteInstallDirTemplates PathTemplateEnv
env InstallDirTemplates
dirs
  where
    env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv PackageIdentifier
pkgId UnitId
libname CompilerInfo
compilerId Platform
platform
    substPrefix :: [a] -> [a] -> [a] -> [a]
substPrefix [a]
pre [a]
root [a]
path
      | [a]
pre [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [a]
path = [a]
root [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
pre) [a]
path
      | Bool
otherwise             = [a]
path


-- |The location prefix for the /copy/ command.
data CopyDest
  = NoCopyDest
  | CopyTo FilePath
  | CopyToDb FilePath
  -- ^ when using the ${pkgroot} as prefix. The CopyToDb will
  --   adjust the paths to be relative to the provided package
  --   database when copying / installing.
  deriving (CopyDest -> CopyDest -> Bool
(CopyDest -> CopyDest -> Bool)
-> (CopyDest -> CopyDest -> Bool) -> Eq CopyDest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CopyDest -> CopyDest -> Bool
$c/= :: CopyDest -> CopyDest -> Bool
== :: CopyDest -> CopyDest -> Bool
$c== :: CopyDest -> CopyDest -> Bool
Eq, Int -> CopyDest -> ShowS
[CopyDest] -> ShowS
CopyDest -> String
(Int -> CopyDest -> ShowS)
-> (CopyDest -> String) -> ([CopyDest] -> ShowS) -> Show CopyDest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CopyDest] -> ShowS
$cshowList :: [CopyDest] -> ShowS
show :: CopyDest -> String
$cshow :: CopyDest -> String
showsPrec :: Int -> CopyDest -> ShowS
$cshowsPrec :: Int -> CopyDest -> ShowS
Show, (forall x. CopyDest -> Rep CopyDest x)
-> (forall x. Rep CopyDest x -> CopyDest) -> Generic CopyDest
forall x. Rep CopyDest x -> CopyDest
forall x. CopyDest -> Rep CopyDest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CopyDest x -> CopyDest
$cfrom :: forall x. CopyDest -> Rep CopyDest x
Generic)

instance Binary CopyDest

-- | Check which of the paths are relative to the installation $prefix.
--
-- If any of the paths are not relative, ie they are absolute paths, then it
-- prevents us from making a relocatable package (also known as a \"prefix
-- independent\" package).
--
prefixRelativeInstallDirs :: PackageIdentifier
                          -> UnitId
                          -> CompilerInfo
                          -> Platform
                          -> InstallDirTemplates
                          -> InstallDirs (Maybe FilePath)
prefixRelativeInstallDirs :: PackageIdentifier
-> UnitId
-> CompilerInfo
-> Platform
-> InstallDirTemplates
-> InstallDirs (Maybe String)
prefixRelativeInstallDirs PackageIdentifier
pkgId UnitId
libname CompilerInfo
compilerId Platform
platform InstallDirTemplates
dirs =
    (PathTemplate -> Maybe String)
-> InstallDirTemplates -> InstallDirs (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> Maybe String
relative
  (InstallDirTemplates -> InstallDirs (Maybe String))
-> (InstallDirTemplates -> InstallDirTemplates)
-> InstallDirTemplates
-> InstallDirs (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathTemplate -> PathTemplate -> PathTemplate)
-> InstallDirTemplates -> InstallDirTemplates
forall a. (a -> a -> a) -> InstallDirs a -> InstallDirs a
appendSubdirs PathTemplate -> PathTemplate -> PathTemplate
combinePathTemplate
  (InstallDirTemplates -> InstallDirs (Maybe String))
-> InstallDirTemplates -> InstallDirs (Maybe String)
forall a b. (a -> b) -> a -> b
$ -- substitute the path template into each other, except that we map
    -- \$prefix back to $prefix. We're trying to end up with templates that
    -- mention no vars except $prefix.
    PathTemplateEnv -> InstallDirTemplates -> InstallDirTemplates
substituteInstallDirTemplates PathTemplateEnv
env InstallDirTemplates
dirs {
      prefix :: PathTemplate
prefix = [PathComponent] -> PathTemplate
PathTemplate [PathTemplateVariable -> PathComponent
Variable PathTemplateVariable
PrefixVar]
    }
  where
    env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv PackageIdentifier
pkgId UnitId
libname CompilerInfo
compilerId Platform
platform

    -- If it starts with $prefix then it's relative and produce the relative
    -- path by stripping off $prefix/ or $prefix
    relative :: PathTemplate -> Maybe String
relative PathTemplate
dir = case PathTemplate
dir of
      PathTemplate [PathComponent]
cs -> ([PathComponent] -> String)
-> Maybe [PathComponent] -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PathTemplate -> String
fromPathTemplate (PathTemplate -> String)
-> ([PathComponent] -> PathTemplate) -> [PathComponent] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PathComponent] -> PathTemplate
PathTemplate) ([PathComponent] -> Maybe [PathComponent]
relative' [PathComponent]
cs)
    relative' :: [PathComponent] -> Maybe [PathComponent]
relative' (Variable PathTemplateVariable
PrefixVar : Ordinary (Char
s:String
rest) : [PathComponent]
rest')
                      | Char -> Bool
isPathSeparator Char
s = [PathComponent] -> Maybe [PathComponent]
forall a. a -> Maybe a
Just (String -> PathComponent
Ordinary String
rest PathComponent -> [PathComponent] -> [PathComponent]
forall a. a -> [a] -> [a]
: [PathComponent]
rest')
    relative' (Variable PathTemplateVariable
PrefixVar : [PathComponent]
rest) = [PathComponent] -> Maybe [PathComponent]
forall a. a -> Maybe a
Just [PathComponent]
rest
    relative' [PathComponent]
_                           = Maybe [PathComponent]
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------------
-- Path templates

-- | An abstract path, possibly containing variables that need to be
-- substituted for to get a real 'FilePath'.
--
newtype PathTemplate = PathTemplate [PathComponent]
  deriving (PathTemplate -> PathTemplate -> Bool
(PathTemplate -> PathTemplate -> Bool)
-> (PathTemplate -> PathTemplate -> Bool) -> Eq PathTemplate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathTemplate -> PathTemplate -> Bool
$c/= :: PathTemplate -> PathTemplate -> Bool
== :: PathTemplate -> PathTemplate -> Bool
$c== :: PathTemplate -> PathTemplate -> Bool
Eq, Eq PathTemplate
Eq PathTemplate
-> (PathTemplate -> PathTemplate -> Ordering)
-> (PathTemplate -> PathTemplate -> Bool)
-> (PathTemplate -> PathTemplate -> Bool)
-> (PathTemplate -> PathTemplate -> Bool)
-> (PathTemplate -> PathTemplate -> Bool)
-> (PathTemplate -> PathTemplate -> PathTemplate)
-> (PathTemplate -> PathTemplate -> PathTemplate)
-> Ord PathTemplate
PathTemplate -> PathTemplate -> Bool
PathTemplate -> PathTemplate -> Ordering
PathTemplate -> PathTemplate -> PathTemplate
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PathTemplate -> PathTemplate -> PathTemplate
$cmin :: PathTemplate -> PathTemplate -> PathTemplate
max :: PathTemplate -> PathTemplate -> PathTemplate
$cmax :: PathTemplate -> PathTemplate -> PathTemplate
>= :: PathTemplate -> PathTemplate -> Bool
$c>= :: PathTemplate -> PathTemplate -> Bool
> :: PathTemplate -> PathTemplate -> Bool
$c> :: PathTemplate -> PathTemplate -> Bool
<= :: PathTemplate -> PathTemplate -> Bool
$c<= :: PathTemplate -> PathTemplate -> Bool
< :: PathTemplate -> PathTemplate -> Bool
$c< :: PathTemplate -> PathTemplate -> Bool
compare :: PathTemplate -> PathTemplate -> Ordering
$ccompare :: PathTemplate -> PathTemplate -> Ordering
$cp1Ord :: Eq PathTemplate
Ord, (forall x. PathTemplate -> Rep PathTemplate x)
-> (forall x. Rep PathTemplate x -> PathTemplate)
-> Generic PathTemplate
forall x. Rep PathTemplate x -> PathTemplate
forall x. PathTemplate -> Rep PathTemplate x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PathTemplate x -> PathTemplate
$cfrom :: forall x. PathTemplate -> Rep PathTemplate x
Generic, Typeable)

instance Binary PathTemplate
instance Structured PathTemplate

type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]

-- | Convert a 'FilePath' to a 'PathTemplate' including any template vars.
--
toPathTemplate :: FilePath -> PathTemplate
toPathTemplate :: String -> PathTemplate
toPathTemplate String
fp = [PathComponent] -> PathTemplate
PathTemplate
    ([PathComponent] -> PathTemplate)
-> (String -> [PathComponent]) -> String -> PathTemplate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PathComponent] -> Maybe [PathComponent] -> [PathComponent]
forall a. a -> Maybe a -> a
fromMaybe (String -> [PathComponent]
forall a. HasCallStack => String -> a
error (String -> [PathComponent]) -> String -> [PathComponent]
forall a b. (a -> b) -> a -> b
$ String
"panic! toPathTemplate " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
fp)
    (Maybe [PathComponent] -> [PathComponent])
-> (String -> Maybe [PathComponent]) -> String -> [PathComponent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe [PathComponent]
forall a. Read a => String -> Maybe a
readMaybe -- TODO: eradicateNoParse
    (String -> PathTemplate) -> String -> PathTemplate
forall a b. (a -> b) -> a -> b
$ String
fp

-- | Convert back to a path, any remaining vars are included
--
fromPathTemplate :: PathTemplate -> FilePath
fromPathTemplate :: PathTemplate -> String
fromPathTemplate (PathTemplate [PathComponent]
template) = [PathComponent] -> String
forall a. Show a => a -> String
show [PathComponent]
template

combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate
combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate
combinePathTemplate (PathTemplate [PathComponent]
t1) (PathTemplate [PathComponent]
t2) =
  [PathComponent] -> PathTemplate
PathTemplate ([PathComponent]
t1 [PathComponent] -> [PathComponent] -> [PathComponent]
forall a. [a] -> [a] -> [a]
++ [String -> PathComponent
Ordinary [Char
pathSeparator]] [PathComponent] -> [PathComponent] -> [PathComponent]
forall a. [a] -> [a] -> [a]
++ [PathComponent]
t2)

substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
environment (PathTemplate [PathComponent]
template) =
    [PathComponent] -> PathTemplate
PathTemplate ((PathComponent -> [PathComponent])
-> [PathComponent] -> [PathComponent]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PathComponent -> [PathComponent]
subst [PathComponent]
template)

    where subst :: PathComponent -> [PathComponent]
subst component :: PathComponent
component@(Ordinary String
_) = [PathComponent
component]
          subst component :: PathComponent
component@(Variable PathTemplateVariable
variable) =
              case PathTemplateVariable -> PathTemplateEnv -> Maybe PathTemplate
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PathTemplateVariable
variable PathTemplateEnv
environment of
                  Just (PathTemplate [PathComponent]
components) -> [PathComponent]
components
                  Maybe PathTemplate
Nothing                        -> [PathComponent
component]

-- | The initial environment has all the static stuff but no paths
initialPathTemplateEnv :: PackageIdentifier
                       -> UnitId
                       -> CompilerInfo
                       -> Platform
                       -> PathTemplateEnv
initialPathTemplateEnv :: PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv PackageIdentifier
pkgId UnitId
libname CompilerInfo
compiler Platform
platform =
     PackageIdentifier -> UnitId -> PathTemplateEnv
packageTemplateEnv  PackageIdentifier
pkgId UnitId
libname
  PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ CompilerInfo -> PathTemplateEnv
compilerTemplateEnv CompilerInfo
compiler
  PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ Platform -> PathTemplateEnv
platformTemplateEnv Platform
platform
  PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ CompilerInfo -> Platform -> PathTemplateEnv
abiTemplateEnv CompilerInfo
compiler Platform
platform

packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv
packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv
packageTemplateEnv PackageIdentifier
pkgId UnitId
uid =
  [(PathTemplateVariable
PkgNameVar,  [PathComponent] -> PathTemplate
PathTemplate [String -> PathComponent
Ordinary (String -> PathComponent) -> String -> PathComponent
forall a b. (a -> b) -> a -> b
$ PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgId)])
  ,(PathTemplateVariable
PkgVerVar,   [PathComponent] -> PathTemplate
PathTemplate [String -> PathComponent
Ordinary (String -> PathComponent) -> String -> PathComponent
forall a b. (a -> b) -> a -> b
$ Version -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion PackageIdentifier
pkgId)])
  -- Invariant: uid is actually a HashedUnitId.  Hard to enforce because
  -- it's an API change.
  ,(PathTemplateVariable
LibNameVar,  [PathComponent] -> PathTemplate
PathTemplate [String -> PathComponent
Ordinary (String -> PathComponent) -> String -> PathComponent
forall a b. (a -> b) -> a -> b
$ UnitId -> String
forall a. Pretty a => a -> String
prettyShow UnitId
uid])
  ,(PathTemplateVariable
PkgIdVar,    [PathComponent] -> PathTemplate
PathTemplate [String -> PathComponent
Ordinary (String -> PathComponent) -> String -> PathComponent
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgId])
  ]

compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv
compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv
compilerTemplateEnv CompilerInfo
compiler =
  [(PathTemplateVariable
CompilerVar, [PathComponent] -> PathTemplate
PathTemplate [String -> PathComponent
Ordinary (String -> PathComponent) -> String -> PathComponent
forall a b. (a -> b) -> a -> b
$ CompilerId -> String
forall a. Pretty a => a -> String
prettyShow (CompilerInfo -> CompilerId
compilerInfoId CompilerInfo
compiler)])
  ]

platformTemplateEnv :: Platform -> PathTemplateEnv
platformTemplateEnv :: Platform -> PathTemplateEnv
platformTemplateEnv (Platform Arch
arch OS
os) =
  [(PathTemplateVariable
OSVar,       [PathComponent] -> PathTemplate
PathTemplate [String -> PathComponent
Ordinary (String -> PathComponent) -> String -> PathComponent
forall a b. (a -> b) -> a -> b
$ OS -> String
forall a. Pretty a => a -> String
prettyShow OS
os])
  ,(PathTemplateVariable
ArchVar,     [PathComponent] -> PathTemplate
PathTemplate [String -> PathComponent
Ordinary (String -> PathComponent) -> String -> PathComponent
forall a b. (a -> b) -> a -> b
$ Arch -> String
forall a. Pretty a => a -> String
prettyShow Arch
arch])
  ]

abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv
abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv
abiTemplateEnv CompilerInfo
compiler (Platform Arch
arch OS
os) =
  [(PathTemplateVariable
AbiVar,      [PathComponent] -> PathTemplate
PathTemplate [String -> PathComponent
Ordinary (String -> PathComponent) -> String -> PathComponent
forall a b. (a -> b) -> a -> b
$ Arch -> String
forall a. Pretty a => a -> String
prettyShow Arch
arch String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'-'Char -> ShowS
forall a. a -> [a] -> [a]
:OS -> String
forall a. Pretty a => a -> String
prettyShow OS
os String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                          Char
'-'Char -> ShowS
forall a. a -> [a] -> [a]
:CompilerId -> String
forall a. Pretty a => a -> String
prettyShow (CompilerInfo -> CompilerId
compilerInfoId CompilerInfo
compiler) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                          case CompilerInfo -> AbiTag
compilerInfoAbiTag CompilerInfo
compiler of
                                            AbiTag
NoAbiTag   -> String
""
                                            AbiTag String
tag -> Char
'-'Char -> ShowS
forall a. a -> [a] -> [a]
:String
tag])
  ,(PathTemplateVariable
AbiTagVar,   [PathComponent] -> PathTemplate
PathTemplate [String -> PathComponent
Ordinary (String -> PathComponent) -> String -> PathComponent
forall a b. (a -> b) -> a -> b
$ AbiTag -> String
abiTagString (CompilerInfo -> AbiTag
compilerInfoAbiTag CompilerInfo
compiler)])
  ]

installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv
installDirsTemplateEnv :: InstallDirTemplates -> PathTemplateEnv
installDirsTemplateEnv InstallDirTemplates
dirs =
  [(PathTemplateVariable
PrefixVar,     InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
prefix     InstallDirTemplates
dirs)
  ,(PathTemplateVariable
BindirVar,     InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
bindir     InstallDirTemplates
dirs)
  ,(PathTemplateVariable
LibdirVar,     InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
libdir     InstallDirTemplates
dirs)
  ,(PathTemplateVariable
LibsubdirVar,  InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
libsubdir  InstallDirTemplates
dirs)
  ,(PathTemplateVariable
DynlibdirVar,  InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
dynlibdir  InstallDirTemplates
dirs)
  ,(PathTemplateVariable
DatadirVar,    InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
datadir    InstallDirTemplates
dirs)
  ,(PathTemplateVariable
DatasubdirVar, InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
datasubdir InstallDirTemplates
dirs)
  ,(PathTemplateVariable
DocdirVar,     InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
docdir     InstallDirTemplates
dirs)
  ,(PathTemplateVariable
HtmldirVar,    InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
htmldir    InstallDirTemplates
dirs)
  ]


-- ---------------------------------------------------------------------------
-- Parsing and showing path templates:

-- The textual format is that of an ordinary Haskell String, eg
-- "$prefix/bin"
-- and this gets parsed to the internal representation as a sequence of path
-- spans which are either strings or variables, eg:
-- PathTemplate [Variable PrefixVar, Ordinary "/bin" ]

instance Show PathTemplate where
  show :: PathTemplate -> String
show (PathTemplate [PathComponent]
template) = ShowS
forall a. Show a => a -> String
show ([PathComponent] -> String
forall a. Show a => a -> String
show [PathComponent]
template)

instance Read PathTemplate where
  readsPrec :: Int -> ReadS PathTemplate
readsPrec Int
p String
s = [ ([PathComponent] -> PathTemplate
PathTemplate [PathComponent]
template, String
s')
                  | (String
path, String
s')     <- Int -> ReadS String
forall a. Read a => Int -> ReadS a
readsPrec Int
p String
s
                  , ([PathComponent]
template, String
"") <- ReadS [PathComponent]
forall a. Read a => ReadS a
reads String
path ]

-- ---------------------------------------------------------------------------
-- Internal utilities

getWindowsProgramFilesDir :: IO FilePath
getWindowsProgramFilesDir :: IO String
getWindowsProgramFilesDir = do
#ifdef mingw32_HOST_OS
  m <- shGetFolderPath csidl_PROGRAM_FILES
#else
  let m :: Maybe a
m = Maybe a
forall a. Maybe a
Nothing
#endif
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"C:\\Program Files" Maybe String
forall a. Maybe a
m)

#ifdef mingw32_HOST_OS
shGetFolderPath :: CInt -> IO (Maybe FilePath)
shGetFolderPath n =
  allocaArray long_path_size $ \pPath -> do
     r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath
     if (r /= 0)
        then return Nothing
        else do s <- peekCWString pPath; return (Just s)
  where
    long_path_size      = 1024 -- MAX_PATH is 260, this should be plenty

csidl_PROGRAM_FILES :: CInt
csidl_PROGRAM_FILES = 0x0026
-- csidl_PROGRAM_FILES_COMMON :: CInt
-- csidl_PROGRAM_FILES_COMMON = 0x002b

#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
#define CALLCONV stdcall
#endif

foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW"
            c_SHGetFolderPath :: Ptr ()
                              -> CInt
                              -> Ptr ()
                              -> CInt
                              -> CWString
                              -> Prelude.IO CInt
#endif