{-# 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

-- | Determine ghc-pkg/haddock path from ghc path
guessCompProgramPaths :: Verbose => Programs -> IO Programs
guessCompProgramPaths :: Programs -> IO Programs
guessCompProgramPaths 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 FilePath
"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 FilePath
"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 FilePath
"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, Maybe Platform
_mplatform, 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 Program
haddockKnownProgram = FilePath -> ProgramDb -> Maybe Program
ProgDb.lookupKnownProgram FilePath
"haddock" ProgramDb
progdb1
  ProgramDb
progdb2 <- Verbosity -> Program -> ProgramDb -> IO ProgramDb
ProgDb.configureProgram Verbosity
v Program
haddockKnownProgram ProgramDb
progdb1
  let getProg :: Program -> Maybe FilePath
getProg 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 Programs
progs 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 SCabalProjType pt
_) 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 ((FilePath
"--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 ((FilePath
"--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 ((FilePath
"--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 SProjType pt
SStack Programs
progs
  -- optimization; if none of the program paths are non-default we don't
  -- even have to add anything to PATH.
  | Programs -> FilePath
ghcProgram Programs
progs FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"ghc"
  , Programs -> FilePath
ghcPkgProgram Programs
progs FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"ghc-pkg"
  , Programs -> FilePath
haddockProgram Programs
progs FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"haddock"
  = Programs -> IO Programs
forall (m :: * -> *) a. Monad m => a -> m a
return Programs
progs

  -- optimization; if all paths are unqualified and have the same version
  -- postfix Stack's default behaviour works for us.
  | [FilePath
ghc] <- FilePath -> [FilePath]
splitPath (Programs -> FilePath
ghcProgram Programs
progs)
  , [FilePath
ghcPkg] <- FilePath -> [FilePath]
splitPath (Programs -> FilePath
ghcPkgProgram Programs
progs)
  , [FilePath
haddock] <- FilePath -> [FilePath]
splitPath (Programs -> FilePath
haddockProgram Programs
progs)
  , Just FilePath
ver <- FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"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 FilePath
"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 FilePath
"haddock-" FilePath
haddock
  = Programs -> IO Programs
forall (m :: * -> *) a. Monad m => a -> m a
return Programs
progs
patchBuildToolProgs SProjType pt
SStack Programs
progs = do
  -- otherwise fall back to creating a symlink farm
  --
  -- This is of course all quite horrible and we would much prefer just
  -- being able to pass executable paths straight through to stack but
  -- currently there is no option to let us do that.
  FilePath -> (FilePath -> IO Programs) -> IO Programs
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"cabal-helper-symlinks" ((FilePath -> IO Programs) -> IO Programs)
-> (FilePath -> IO Programs) -> IO Programs
forall a b. (a -> b) -> a -> b
$ \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 =
        [(FilePath
"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 Bool
required FilePath
bindir FilePath
target
  | [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 FilePath
exe_path -> FilePath -> FilePath -> IO ()
createSymbolicLink FilePath
exe_path (FilePath
bindir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeFileName FilePath
target)
      Maybe FilePath
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
$ FilePath
"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 -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
exe FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" 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)