{-# 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 Distribution.Compat.Prelude
import Prelude ()

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

import System.Directory (getAppUserDataDirectory)
import System.FilePath
  ( dropDrive
  , isPathSeparator
  , pathSeparator
  , 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
  { forall dir. InstallDirs dir -> dir
prefix :: dir
  , forall dir. InstallDirs dir -> dir
bindir :: dir
  , forall dir. InstallDirs dir -> dir
libdir :: dir
  , forall dir. InstallDirs dir -> dir
libsubdir :: dir
  , forall dir. InstallDirs dir -> dir
dynlibdir :: dir
  , forall dir. InstallDirs dir -> dir
flibdir :: dir
  -- ^ foreign libraries
  , forall dir. InstallDirs dir -> dir
libexecdir :: dir
  , forall dir. InstallDirs dir -> dir
libexecsubdir :: dir
  , forall dir. InstallDirs dir -> dir
includedir :: dir
  , forall dir. InstallDirs dir -> dir
datadir :: dir
  , forall dir. InstallDirs dir -> dir
datasubdir :: dir
  , forall dir. InstallDirs dir -> dir
docdir :: dir
  , forall dir. InstallDirs dir -> dir
mandir :: dir
  , forall dir. InstallDirs dir -> dir
htmldir :: dir
  , forall dir. InstallDirs dir -> dir
haddockdir :: dir
  , forall 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
$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
/= :: 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
$creadsPrec :: forall dir. Read dir => Int -> ReadS (InstallDirs dir)
readsPrec :: Int -> ReadS (InstallDirs dir)
$creadList :: forall dir. Read dir => ReadS [InstallDirs dir]
readList :: ReadS [InstallDirs dir]
$creadPrec :: forall dir. Read dir => ReadPrec (InstallDirs dir)
readPrec :: ReadPrec (InstallDirs dir)
$creadListPrec :: forall dir. Read dir => ReadPrec [InstallDirs dir]
readListPrec :: ReadPrec [InstallDirs dir]
Read, Int -> InstallDirs dir -> ShowS
[InstallDirs dir] -> ShowS
InstallDirs dir -> FilePath
(Int -> InstallDirs dir -> ShowS)
-> (InstallDirs dir -> FilePath)
-> ([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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall dir. Show dir => Int -> InstallDirs dir -> ShowS
showsPrec :: Int -> InstallDirs dir -> ShowS
$cshow :: forall dir. Show dir => InstallDirs dir -> FilePath
show :: InstallDirs dir -> FilePath
$cshowList :: forall dir. Show dir => [InstallDirs dir] -> ShowS
showList :: [InstallDirs dir] -> ShowS
Show, (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
$cfmap :: forall a b. (a -> b) -> InstallDirs a -> InstallDirs b
fmap :: forall a b. (a -> b) -> InstallDirs a -> InstallDirs b
$c<$ :: forall a b. a -> InstallDirs b -> InstallDirs a
<$ :: forall a b. a -> InstallDirs b -> InstallDirs a
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
$cfrom :: forall dir x. InstallDirs dir -> Rep (InstallDirs dir) x
from :: forall x. InstallDirs dir -> Rep (InstallDirs dir) x
$cto :: forall dir x. Rep (InstallDirs dir) x -> InstallDirs dir
to :: forall x. Rep (InstallDirs dir) x -> InstallDirs dir
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 :: forall a b c.
(a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c
combineInstallDirs a -> b -> c
combine InstallDirs a
a InstallDirs b
b =
  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 :: forall a. (a -> a -> a) -> InstallDirs a -> InstallDirs a
appendSubdirs a -> a -> a
append InstallDirs a
dirs =
  InstallDirs a
dirs
    { libdir = libdir dirs `append` libsubdir dirs
    , libexecdir = libexecdir dirs `append` libexecsubdir dirs
    , datadir = datadir dirs `append` datasubdir dirs
    , libsubdir = error "internal error InstallDirs.libsubdir"
    , libexecsubdir = error "internal error InstallDirs.libexecsubdir"
    , datasubdir = error "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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    InstallDirTemplates
dflt
      { datasubdir = toPathTemplate $ "$abi" </> "$libname"
      , docdir = toPathTemplate $ "$datadir" </> "doc" </> "$abi" </> "$libname"
      }
defaultInstallDirs' Bool
False CompilerFlavor
comp Bool
userInstall Bool
_hasLibs = do
  FilePath
installPrefix <-
    if Bool
userInstall
      then do
        Maybe FilePath
mDir <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"CABAL_DIR"
        case Maybe FilePath
mDir of
          Maybe FilePath
Nothing -> FilePath -> IO FilePath
getAppUserDataDirectory FilePath
"cabal"
          Just FilePath
dir -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir
      else case OS
buildOS of
        OS
Windows -> do
          FilePath
windowsProgramFilesDir <- IO FilePath
getWindowsProgramFilesDir
          FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
windowsProgramFilesDir FilePath -> ShowS
</> FilePath
"Haskell")
        OS
Haiku -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"/boot/system/non-packaged"
        OS
_ -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"/usr/local"
  FilePath
installLibDir <-
    case OS
buildOS of
      OS
Windows -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"$prefix"
      OS
_ -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
"$prefix" FilePath -> ShowS
</> FilePath
"lib")
  InstallDirTemplates -> IO InstallDirTemplates
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstallDirTemplates -> IO InstallDirTemplates)
-> InstallDirTemplates -> IO InstallDirTemplates
forall a b. (a -> b) -> a -> b
$
    (FilePath -> PathTemplate)
-> InstallDirs FilePath -> InstallDirTemplates
forall a b. (a -> b) -> InstallDirs a -> InstallDirs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> PathTemplate
toPathTemplate (InstallDirs FilePath -> InstallDirTemplates)
-> InstallDirs FilePath -> InstallDirTemplates
forall a b. (a -> b) -> a -> b
$
      InstallDirs
        { prefix :: FilePath
prefix = FilePath
installPrefix
        , bindir :: FilePath
bindir = FilePath
"$prefix" FilePath -> ShowS
</> FilePath
"bin"
        , libdir :: FilePath
libdir = FilePath
installLibDir
        , libsubdir :: FilePath
libsubdir = case CompilerFlavor
comp of
            CompilerFlavor
UHC -> FilePath
"$pkgid"
            CompilerFlavor
_other -> FilePath
"$abi" FilePath -> ShowS
</> FilePath
"$libname"
        , dynlibdir :: FilePath
dynlibdir =
            FilePath
"$libdir" FilePath -> ShowS
</> case CompilerFlavor
comp of
              CompilerFlavor
UHC -> FilePath
"$pkgid"
              CompilerFlavor
_other -> FilePath
"$abi"
        , libexecsubdir :: FilePath
libexecsubdir = FilePath
"$abi" FilePath -> ShowS
</> FilePath
"$pkgid"
        , flibdir :: FilePath
flibdir = FilePath
"$libdir"
        , libexecdir :: FilePath
libexecdir = case OS
buildOS of
            OS
Windows -> FilePath
"$prefix" FilePath -> ShowS
</> FilePath
"$libname"
            OS
Haiku -> FilePath
"$libdir"
            OS
_other -> FilePath
"$prefix" FilePath -> ShowS
</> FilePath
"libexec"
        , includedir :: FilePath
includedir = case OS
buildOS of
            OS
Haiku -> FilePath
"$prefix" FilePath -> ShowS
</> FilePath
"develop" FilePath -> ShowS
</> FilePath
"headers"
            OS
_other -> FilePath
"$libdir" FilePath -> ShowS
</> FilePath
"$libsubdir" FilePath -> ShowS
</> FilePath
"include"
        , datadir :: FilePath
datadir = case OS
buildOS of
            OS
Windows -> FilePath
"$prefix"
            OS
Haiku -> FilePath
"$prefix" FilePath -> ShowS
</> FilePath
"data"
            OS
_other -> FilePath
"$prefix" FilePath -> ShowS
</> FilePath
"share"
        , datasubdir :: FilePath
datasubdir = FilePath
"$abi" FilePath -> ShowS
</> FilePath
"$pkgid"
        , docdir :: FilePath
docdir = case OS
buildOS of
            OS
Haiku -> FilePath
"$prefix" FilePath -> ShowS
</> FilePath
"documentation"
            OS
_other -> FilePath
"$datadir" FilePath -> ShowS
</> FilePath
"doc" FilePath -> ShowS
</> FilePath
"$abi" FilePath -> ShowS
</> FilePath
"$pkgid"
        , mandir :: FilePath
mandir = case OS
buildOS of
            OS
Haiku -> FilePath
"$docdir" FilePath -> ShowS
</> FilePath
"man"
            OS
_other -> FilePath
"$datadir" FilePath -> ShowS
</> FilePath
"man"
        , htmldir :: FilePath
htmldir = FilePath
"$docdir" FilePath -> ShowS
</> FilePath
"html"
        , haddockdir :: FilePath
haddockdir = FilePath
"$htmldir"
        , sysconfdir :: FilePath
sysconfdir = case OS
buildOS of
            OS
Haiku -> FilePath
"boot" FilePath -> ShowS
</> FilePath
"system" FilePath -> ShowS
</> FilePath
"settings"
            OS
_other -> FilePath
"$prefix" FilePath -> ShowS
</> FilePath
"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
        { -- 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 FilePath
absoluteInstallDirs PackageIdentifier
pkgId UnitId
libname CompilerInfo
compilerId CopyDest
copydest Platform
platform InstallDirTemplates
dirs =
  ( case CopyDest
copydest of
      CopyTo FilePath
destdir -> ShowS -> InstallDirs FilePath -> InstallDirs FilePath
forall a b. (a -> b) -> InstallDirs a -> InstallDirs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath
destdir FilePath -> ShowS
</>) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropDrive)
      CopyToDb FilePath
dbdir -> ShowS -> InstallDirs FilePath -> InstallDirs FilePath
forall a b. (a -> b) -> InstallDirs a -> InstallDirs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> ShowS
forall {a}. Eq a => [a] -> [a] -> [a] -> [a]
substPrefix FilePath
"${pkgroot}" (ShowS
takeDirectory FilePath
dbdir))
      CopyDest
_ -> InstallDirs FilePath -> InstallDirs FilePath
forall a. a -> a
id
  )
    (InstallDirs FilePath -> InstallDirs FilePath)
-> (InstallDirTemplates -> InstallDirs FilePath)
-> InstallDirTemplates
-> InstallDirs FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> ShowS) -> InstallDirs FilePath -> InstallDirs FilePath
forall a. (a -> a -> a) -> InstallDirs a -> InstallDirs a
appendSubdirs FilePath -> ShowS
(</>)
    (InstallDirs FilePath -> InstallDirs FilePath)
-> (InstallDirTemplates -> InstallDirs FilePath)
-> InstallDirTemplates
-> InstallDirs FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathTemplate -> FilePath)
-> InstallDirTemplates -> InstallDirs FilePath
forall a b. (a -> b) -> InstallDirs a -> InstallDirs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> FilePath
fromPathTemplate
    (InstallDirTemplates -> InstallDirs FilePath)
-> InstallDirTemplates -> InstallDirs FilePath
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 a. [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
  | -- | when using the ${pkgroot} as prefix. The CopyToDb will
    --   adjust the paths to be relative to the provided package
    --   database when copying / installing.
    CopyToDb FilePath
  deriving (CopyDest -> CopyDest -> Bool
(CopyDest -> CopyDest -> Bool)
-> (CopyDest -> CopyDest -> Bool) -> Eq CopyDest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CopyDest -> CopyDest -> Bool
== :: CopyDest -> CopyDest -> Bool
$c/= :: CopyDest -> CopyDest -> Bool
/= :: CopyDest -> CopyDest -> Bool
Eq, Int -> CopyDest -> ShowS
[CopyDest] -> ShowS
CopyDest -> FilePath
(Int -> CopyDest -> ShowS)
-> (CopyDest -> FilePath) -> ([CopyDest] -> ShowS) -> Show CopyDest
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CopyDest -> ShowS
showsPrec :: Int -> CopyDest -> ShowS
$cshow :: CopyDest -> FilePath
show :: CopyDest -> FilePath
$cshowList :: [CopyDest] -> ShowS
showList :: [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
$cfrom :: forall x. CopyDest -> Rep CopyDest x
from :: forall x. CopyDest -> Rep CopyDest x
$cto :: forall x. Rep CopyDest x -> CopyDest
to :: forall x. Rep CopyDest x -> CopyDest
Generic)

instance Binary CopyDest
instance Structured 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 FilePath)
prefixRelativeInstallDirs PackageIdentifier
pkgId UnitId
libname CompilerInfo
compilerId Platform
platform InstallDirTemplates
dirs =
  (PathTemplate -> Maybe FilePath)
-> InstallDirTemplates -> InstallDirs (Maybe FilePath)
forall a b. (a -> b) -> InstallDirs a -> InstallDirs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> Maybe FilePath
relative
    (InstallDirTemplates -> InstallDirs (Maybe FilePath))
-> (InstallDirTemplates -> InstallDirTemplates)
-> InstallDirTemplates
-> InstallDirs (Maybe FilePath)
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 FilePath))
-> InstallDirTemplates -> InstallDirs (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ PathTemplateEnv -> InstallDirTemplates -> InstallDirTemplates
substituteInstallDirTemplates -- 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
env
      InstallDirTemplates
dirs
        { prefix = PathTemplate [Variable 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 FilePath
relative PathTemplate
dir = case PathTemplate
dir of
      PathTemplate [PathComponent]
cs -> ([PathComponent] -> FilePath)
-> Maybe [PathComponent] -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PathTemplate -> FilePath
fromPathTemplate (PathTemplate -> FilePath)
-> ([PathComponent] -> PathTemplate) -> [PathComponent] -> FilePath
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 : FilePath
rest) : [PathComponent]
rest')
      | Char -> Bool
isPathSeparator Char
s = [PathComponent] -> Maybe [PathComponent]
forall a. a -> Maybe a
Just (FilePath -> PathComponent
Ordinary FilePath
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
$c== :: PathTemplate -> PathTemplate -> Bool
== :: PathTemplate -> PathTemplate -> Bool
$c/= :: PathTemplate -> PathTemplate -> Bool
/= :: 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
$ccompare :: PathTemplate -> PathTemplate -> Ordering
compare :: PathTemplate -> PathTemplate -> Ordering
$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
>= :: PathTemplate -> PathTemplate -> Bool
$cmax :: PathTemplate -> PathTemplate -> PathTemplate
max :: PathTemplate -> PathTemplate -> PathTemplate
$cmin :: PathTemplate -> PathTemplate -> PathTemplate
min :: PathTemplate -> PathTemplate -> 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
$cfrom :: forall x. PathTemplate -> Rep PathTemplate x
from :: forall x. PathTemplate -> Rep PathTemplate x
$cto :: forall x. Rep PathTemplate x -> PathTemplate
to :: forall x. Rep PathTemplate x -> PathTemplate
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 :: FilePath -> PathTemplate
toPathTemplate FilePath
fp =
  [PathComponent] -> PathTemplate
PathTemplate
    ([PathComponent] -> PathTemplate)
-> (FilePath -> [PathComponent]) -> FilePath -> PathTemplate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PathComponent] -> Maybe [PathComponent] -> [PathComponent]
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> [PathComponent]
forall a. HasCallStack => FilePath -> a
error (FilePath -> [PathComponent]) -> FilePath -> [PathComponent]
forall a b. (a -> b) -> a -> b
$ FilePath
"panic! toPathTemplate " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> FilePath
show FilePath
fp)
    (Maybe [PathComponent] -> [PathComponent])
-> (FilePath -> Maybe [PathComponent])
-> FilePath
-> [PathComponent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe [PathComponent]
forall a. Read a => FilePath -> Maybe a
readMaybe -- TODO: eradicateNoParse
    (FilePath -> PathTemplate) -> FilePath -> PathTemplate
forall a b. (a -> b) -> a -> b
$ FilePath
fp

-- | Convert back to a path, any remaining vars are included
fromPathTemplate :: PathTemplate -> FilePath
fromPathTemplate :: PathTemplate -> FilePath
fromPathTemplate (PathTemplate [PathComponent]
template) = [PathComponent] -> FilePath
forall a. Show a => a -> FilePath
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]
++ [FilePath -> 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 FilePath
_) = [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 [FilePath -> PathComponent
Ordinary (FilePath -> PathComponent) -> FilePath -> PathComponent
forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgId)])
  , (PathTemplateVariable
PkgVerVar, [PathComponent] -> PathTemplate
PathTemplate [FilePath -> PathComponent
Ordinary (FilePath -> PathComponent) -> FilePath -> PathComponent
forall a b. (a -> b) -> a -> b
$ Version -> FilePath
forall a. Pretty a => a -> FilePath
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 [FilePath -> PathComponent
Ordinary (FilePath -> PathComponent) -> FilePath -> PathComponent
forall a b. (a -> b) -> a -> b
$ UnitId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnitId
uid])
  , (PathTemplateVariable
PkgIdVar, [PathComponent] -> PathTemplate
PathTemplate [FilePath -> PathComponent
Ordinary (FilePath -> PathComponent) -> FilePath -> PathComponent
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgId])
  ]

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

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

abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv
abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv
abiTemplateEnv CompilerInfo
compiler (Platform Arch
arch OS
os) =
  [
    ( PathTemplateVariable
AbiVar
    , [PathComponent] -> PathTemplate
PathTemplate
        [ FilePath -> PathComponent
Ordinary (FilePath -> PathComponent) -> FilePath -> PathComponent
forall a b. (a -> b) -> a -> b
$
            Arch -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Arch
arch
              FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'-'
              Char -> ShowS
forall a. a -> [a] -> [a]
: OS -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow OS
os
              FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'-'
              Char -> ShowS
forall a. a -> [a] -> [a]
: CompilerId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (CompilerInfo -> CompilerId
compilerInfoId CompilerInfo
compiler)
              FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ case CompilerInfo -> AbiTag
compilerInfoAbiTag CompilerInfo
compiler of
                AbiTag
NoAbiTag -> FilePath
""
                AbiTag FilePath
tag -> Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: FilePath
tag
        ]
    )
  , (PathTemplateVariable
AbiTagVar, [PathComponent] -> PathTemplate
PathTemplate [FilePath -> PathComponent
Ordinary (FilePath -> PathComponent) -> FilePath -> PathComponent
forall a b. (a -> b) -> a -> b
$ AbiTag -> FilePath
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 -> FilePath
show (PathTemplate [PathComponent]
template) = ShowS
forall a. Show a => a -> FilePath
show ([PathComponent] -> FilePath
forall a. Show a => a -> FilePath
show [PathComponent]
template)

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

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

{- FOURMOLU_DISABLE -}
getWindowsProgramFilesDir :: IO FilePath
getWindowsProgramFilesDir :: IO FilePath
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
  FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"C:\\Program Files" Maybe FilePath
forall a. Maybe a
m)
{- FOURMOLU_ENABLE -}

#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

{- FOURMOLU_DISABLE -}
#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
{- FOURMOLU_ENABLE -}