{-# LANGUAGE GADTs #-}
module CabalHelper.Compiletime.CompPrograms where
import Control.Monad (when)
import Data.List
import Data.Maybe
import System.Directory
import System.FilePath
import System.IO.Temp
import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Cabal (getCabalVerbosity)
import CabalHelper.Shared.Common (panicIO)
import Symlink (createSymbolicLink)
import Distribution.Simple.GHC as GHC (configure)
import qualified Distribution.Simple.Program as ProgDb
( lookupProgram, lookupKnownProgram, programPath
, configureProgram, userMaybeSpecifyPath
, ghcProgram, ghcPkgProgram, haddockProgram )
import qualified Distribution.Simple.Program.Db as ProgDb
guessCompProgramPaths :: Verbose => Programs -> IO Programs
guessCompProgramPaths :: Programs -> IO Programs
guessCompProgramPaths progs :: Programs
progs = do
let v :: Verbosity
v = Verbosity
Verbose => Verbosity
getCabalVerbosity
getMaybeProg' :: (Programs -> FilePath) -> Maybe FilePath
getMaybeProg' = Programs -> (Programs -> FilePath) -> Maybe FilePath
getMaybeProg Programs
progs
progdb :: ProgramDb
progdb =
FilePath -> Maybe FilePath -> ProgramDb -> ProgramDb
ProgDb.userMaybeSpecifyPath "ghc" ((Programs -> FilePath) -> Maybe FilePath
getMaybeProg' Programs -> FilePath
ghcProgram) (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall a b. (a -> b) -> a -> b
$
FilePath -> Maybe FilePath -> ProgramDb -> ProgramDb
ProgDb.userMaybeSpecifyPath "ghc-pkg" ((Programs -> FilePath) -> Maybe FilePath
getMaybeProg' Programs -> FilePath
ghcPkgProgram) (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall a b. (a -> b) -> a -> b
$
FilePath -> Maybe FilePath -> ProgramDb -> ProgramDb
ProgDb.userMaybeSpecifyPath "haddock" ((Programs -> FilePath) -> Maybe FilePath
getMaybeProg' Programs -> FilePath
haddockProgram) (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall a b. (a -> b) -> a -> b
$
ProgramDb
ProgDb.defaultProgramDb
(_compiler :: Compiler
_compiler, _mplatform :: Maybe Platform
_mplatform, progdb1 :: ProgramDb
progdb1) <- Verbosity
-> Maybe FilePath
-> Maybe FilePath
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
GHC.configure Verbosity
v Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing ProgramDb
progdb
let Just haddockKnownProgram :: Program
haddockKnownProgram = FilePath -> ProgramDb -> Maybe Program
ProgDb.lookupKnownProgram "haddock" ProgramDb
progdb1
ProgramDb
progdb2 <- Verbosity -> Program -> ProgramDb -> IO ProgramDb
ProgDb.configureProgram Verbosity
v Program
haddockKnownProgram ProgramDb
progdb1
let getProg :: Program -> Maybe FilePath
getProg p :: Program
p = ConfiguredProgram -> FilePath
ProgDb.programPath (ConfiguredProgram -> FilePath)
-> Maybe ConfiguredProgram -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Program -> ProgramDb -> Maybe ConfiguredProgram
ProgDb.lookupProgram Program
p ProgramDb
progdb2
Programs -> IO Programs
forall (m :: * -> *) a. Monad m => a -> m a
return Programs
progs
{ ghcProgram :: FilePath
ghcProgram =
FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (Programs -> FilePath
ghcProgram Programs
progs) (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Program -> Maybe FilePath
getProg Program
ProgDb.ghcProgram
, ghcPkgProgram :: FilePath
ghcPkgProgram =
FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (Programs -> FilePath
ghcPkgProgram Programs
progs) (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Program -> Maybe FilePath
getProg Program
ProgDb.ghcPkgProgram
, haddockProgram :: FilePath
haddockProgram =
FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (Programs -> FilePath
haddockProgram Programs
progs) (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Program -> Maybe FilePath
getProg Program
ProgDb.haddockProgram
}
getMaybeProg :: Programs -> (Programs -> FilePath) -> Maybe FilePath
getMaybeProg :: Programs -> (Programs -> FilePath) -> Maybe FilePath
getMaybeProg progs :: Programs
progs fn :: Programs -> FilePath
fn
| Programs -> FilePath
fn Programs
progs FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Programs -> FilePath
fn Programs
defaultPrograms = Maybe FilePath
forall a. Maybe a
Nothing
| Bool
otherwise = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Programs -> FilePath
fn Programs
progs)
patchBuildToolProgs :: SProjType pt -> Programs -> IO Programs
patchBuildToolProgs :: SProjType pt -> Programs -> IO Programs
patchBuildToolProgs (SCabal _) progs :: Programs
progs = Programs -> IO Programs
forall (m :: * -> *) a. Monad m => a -> m a
return Programs
progs
{ cabalUnitArgs :: [FilePath]
cabalUnitArgs = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList (("--with-ghc="FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Programs -> (Programs -> FilePath) -> Maybe FilePath
getMaybeProg Programs
progs Programs -> FilePath
ghcProgram)
, Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList (("--with-ghc-pkg="FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Programs -> (Programs -> FilePath) -> Maybe FilePath
getMaybeProg Programs
progs Programs -> FilePath
ghcPkgProgram)
, Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList (("--with-haddock="FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Programs -> (Programs -> FilePath) -> Maybe FilePath
getMaybeProg Programs
progs Programs -> FilePath
haddockProgram)
] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ Programs -> [FilePath]
cabalUnitArgs Programs
progs
}
patchBuildToolProgs SStack progs :: Programs
progs
| Programs -> FilePath
ghcProgram Programs
progs FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "ghc"
, Programs -> FilePath
ghcPkgProgram Programs
progs FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "ghc-pkg"
, Programs -> FilePath
haddockProgram Programs
progs FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "haddock"
= Programs -> IO Programs
forall (m :: * -> *) a. Monad m => a -> m a
return Programs
progs
| [ghc :: FilePath
ghc] <- FilePath -> [FilePath]
splitPath (Programs -> FilePath
ghcProgram Programs
progs)
, [ghcPkg :: FilePath
ghcPkg] <- FilePath -> [FilePath]
splitPath (Programs -> FilePath
ghcPkgProgram Programs
progs)
, [haddock :: FilePath
haddock] <- FilePath -> [FilePath]
splitPath (Programs -> FilePath
haddockProgram Programs
progs)
, Just ver :: FilePath
ver <- FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "ghc-" FilePath
ghc
, FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
ver Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "ghc-pkg-" FilePath
ghcPkg
, FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
ver Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "haddock-" FilePath
haddock
= Programs -> IO Programs
forall (m :: * -> *) a. Monad m => a -> m a
return Programs
progs
patchBuildToolProgs SStack progs :: Programs
progs = do
FilePath -> (FilePath -> IO Programs) -> IO Programs
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory "cabal-helper-symlinks" ((FilePath -> IO Programs) -> IO Programs)
-> (FilePath -> IO Programs) -> IO Programs
forall a b. (a -> b) -> a -> b
$ \bindir :: FilePath
bindir -> do
Bool -> FilePath -> FilePath -> IO ()
createProgSymlink Bool
True FilePath
bindir (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Programs -> FilePath
ghcProgram Programs
progs
Bool -> FilePath -> FilePath -> IO ()
createProgSymlink Bool
True FilePath
bindir (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Programs -> FilePath
ghcPkgProgram Programs
progs
Bool -> FilePath -> FilePath -> IO ()
createProgSymlink Bool
False FilePath
bindir (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Programs -> FilePath
haddockProgram Programs
progs
Programs -> IO Programs
forall (m :: * -> *) a. Monad m => a -> m a
return (Programs -> IO Programs) -> Programs -> IO Programs
forall a b. (a -> b) -> a -> b
$ Programs
progs
{ stackEnv :: [(FilePath, EnvOverride)]
stackEnv =
[("PATH", FilePath -> EnvOverride
EnvPrepend (FilePath -> EnvOverride) -> FilePath -> EnvOverride
forall a b. (a -> b) -> a -> b
$ FilePath
bindir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Char
searchPathSeparator])] [(FilePath, EnvOverride)]
-> [(FilePath, EnvOverride)] -> [(FilePath, EnvOverride)]
forall a. [a] -> [a] -> [a]
++
Programs -> [(FilePath, EnvOverride)]
stackEnv Programs
progs
}
createProgSymlink :: Bool -> FilePath -> FilePath -> IO ()
createProgSymlink :: Bool -> FilePath -> FilePath -> IO ()
createProgSymlink required :: Bool
required bindir :: FilePath
bindir target :: FilePath
target
| [exe :: FilePath
exe] <- FilePath -> [FilePath]
splitPath FilePath
target = do
Maybe FilePath
mb_exe_path <- FilePath -> IO (Maybe FilePath)
findExecutable FilePath
exe
case Maybe FilePath
mb_exe_path of
Just exe_path :: FilePath
exe_path -> FilePath -> FilePath -> IO ()
createSymbolicLink FilePath
exe_path (FilePath
bindir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeFileName FilePath
target)
Nothing -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
required (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. FilePath -> IO a
panicIO (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Error trying to create symlink to '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
target FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "': "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "'" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
exe FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "'" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " executable not found."
| Bool
otherwise = do
FilePath
cwd <- IO FilePath
getCurrentDirectory
FilePath -> FilePath -> IO ()
createSymbolicLink (FilePath
cwd FilePath -> FilePath -> FilePath
</> FilePath
target) (FilePath
bindir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeFileName FilePath
target)