diff options
| -rw-r--r-- | cabal-helper.cabal | 23 | ||||
| -rw-r--r-- | lib/Distribution/Helper.hs | 64 | ||||
| -rw-r--r-- | os/posix/Symlink.hs | 2 | ||||
| -rw-r--r-- | os/win/Symlink.hs | 3 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Cabal.hs | 9 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/CompPrograms.hs | 99 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 7 | ||||
| -rw-r--r-- | tests/ProgramsTest.hs | 76 |
8 files changed, 222 insertions, 61 deletions
diff --git a/cabal-helper.cabal b/cabal-helper.cabal index 384a849..db777ad 100644 --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -120,10 +120,13 @@ common build-deps , temporary < 1.3 && >= 1.2.1 , time < 1.9 && >= 1.6.0.1 , transformers < 0.6 && >= 0.5.2.0 - if !os(windows) + , utf8-string < 1.1 && >= 1.0.1.1 + if os(windows) + build-depends: Win32 < 2.9 && >= 2.8.3.0 + else build-depends: unix < 2.8 && >= 2.7.2.1 build-depends: unix-compat < 0.6 && >= 0.4.3.1 - , utf8-string < 1.1 && >= 1.0.1.1 + if flag(dev) ghc-options: -Wall @@ -132,6 +135,7 @@ library c-h-internal import: build-deps, extensions exposed-modules: CabalHelper.Compiletime.Cabal + CabalHelper.Compiletime.CompPrograms CabalHelper.Compiletime.Compat.Environment CabalHelper.Compiletime.Compat.Version CabalHelper.Compiletime.Compat.Parsec @@ -153,6 +157,12 @@ library c-h-internal Paths_cabal_helper autogen-modules: Paths_cabal_helper + exposed-modules: + Symlink + if os(windows) + hs-source-dirs: os/win + else + hs-source-dirs: os/posix hs-source-dirs: src library @@ -174,7 +184,14 @@ test-suite compile-test ghc-options: -Wall build-depends: c-h-internal - +test-suite programs-test + import: build-deps, extensions + type: exitcode-stdio-1.0 + main-is: ProgramsTest.hs + hs-source-dirs: tests + ghc-options: -Wall + build-depends: c-h-internal + , pretty-show test-suite ghc-session import: build-deps, extensions diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index 8a3781c..806bf54 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -147,6 +147,7 @@ import qualified CabalHelper.Compiletime.Program.Stack as Stack import qualified CabalHelper.Compiletime.Program.GHC as GHC import qualified CabalHelper.Compiletime.Program.CabalInstall as CabalInstall import CabalHelper.Compiletime.Cabal +import CabalHelper.Compiletime.CompPrograms import CabalHelper.Compiletime.Log import CabalHelper.Compiletime.Process import CabalHelper.Compiletime.Sandbox @@ -160,14 +161,6 @@ import CabalHelper.Compiletime.Compat.Version import Distribution.System (buildPlatform) import Distribution.Text (display) -import Distribution.Verbosity (Verbosity, silent, normal, verbose, deafening) -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 -- $type-conventions -- Throughout the API we use the following conventions for type variables: @@ -754,55 +747,12 @@ getConfProgs qe = do -- | Fixup program paths as appropriate for current project-type and bring -- 'Programs' into scope as an implicit parameter. configurePrograms :: QueryEnvI c pt -> PreInfo pt -> IO Programs -configurePrograms QueryEnv{..} pre_info = withVerbosity $ do - guessCompProgramPaths $ case pre_info of - PreInfoStack projPaths -> - Stack.patchCompPrograms projPaths qePrograms - _ -> qePrograms - where - -- | Determine ghc-pkg path from ghc path - guessCompProgramPaths :: Verbose => Programs -> IO Programs - guessCompProgramPaths progs - | same ghcProgram progs dprogs = return progs - guessCompProgramPaths progs = do - let v = getCabalVerbosity - mGhcPath0 | same ghcProgram progs dprogs = Nothing - | otherwise = Just $ ghcProgram progs - mGhcPkgPath0 | same ghcPkgProgram progs dprogs = Nothing - | otherwise = Just $ ghcPkgProgram progs - (_compiler, _mplatform, progdb) - <- GHC.configure - v - mGhcPath0 - mGhcPkgPath0 - ProgDb.defaultProgramDb - let getProg p = ProgDb.programPath <$> ProgDb.lookupProgram p progdb - mghcPath1 = getProg ProgDb.ghcProgram - mghcPkgPath1 = getProg ProgDb.ghcPkgProgram - ghc = fromMaybe (ghcProgram progs) mghcPath1 - ghc_pkg = fromMaybe (ghcPkgProgram progs) mghcPkgPath1 - return progs - { ghcProgram = ghc - , ghcPkgProgram = ghc_pkg - , stackEnv = stackEnv progs ++ - -- TODO: this is a cludge, need to make a symlink farm for - -- stack instead. Note: Haddock also has to be in the compiler - -- dir. - [("PATH", EnvPrepend $ takeDirectory ghc ++ [searchPathSeparator])] - , cabalUnitArgs = cabalUnitArgs progs ++ - maybeToList (("--with-ghc="++) <$> mghcPath1) ++ - maybeToList (("--with-ghc-pkg="++) <$> mghcPkgPath1) - } - - same f o o' = f o == f o' - dprogs = defaultPrograms - -getCabalVerbosity :: Verbose => Verbosity -getCabalVerbosity - | ?verbose 2 = normal - | ?verbose 3 = verbose - | ?verbose 4 = deafening - | otherwise = silent +configurePrograms qe@QueryEnv{..} pre_info = withVerbosity $ do + patchBuildToolProgs (projTypeOfQueryEnv qe) <=< guessCompProgramPaths $ + case pre_info of + PreInfoStack projPaths -> + Stack.patchCompPrograms projPaths qePrograms + _ -> qePrograms newtype Helper pt = Helper { runHelper :: Unit pt -> [String] -> IO [Maybe ChResponse] } diff --git a/os/posix/Symlink.hs b/os/posix/Symlink.hs new file mode 100644 index 0000000..6d97072 --- /dev/null +++ b/os/posix/Symlink.hs @@ -0,0 +1,2 @@ +module Symlink (createSymbolicLink) where +import System.Posix.Files (createSymbolicLink) diff --git a/os/win/Symlink.hs b/os/win/Symlink.hs new file mode 100644 index 0000000..335f1c4 --- /dev/null +++ b/os/win/Symlink.hs @@ -0,0 +1,3 @@ +module Symlink (createSymbolicLink) where +import System.Win32.SymbolicLink (createSymbolicLinkFile) +createSymbolicLink = createSymbolicLinkFile diff --git a/src/CabalHelper/Compiletime/Cabal.hs b/src/CabalHelper/Compiletime/Cabal.hs index c8afab8..d39761d 100644 --- a/src/CabalHelper/Compiletime/Cabal.hs +++ b/src/CabalHelper/Compiletime/Cabal.hs @@ -37,6 +37,8 @@ import System.FilePath import System.IO import Text.Printf +import Distribution.Verbosity (Verbosity, silent, normal, verbose, deafening) + import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 @@ -285,3 +287,10 @@ parseSetupHeader header = case BS8.words header of <*> parsePkgIdBS setupId <*> parsePkgIdBS compId _ -> Nothing + +getCabalVerbosity :: Verbose => Verbosity +getCabalVerbosity + | ?verbose 2 = normal + | ?verbose 3 = verbose + | ?verbose 4 = deafening + | otherwise = silent diff --git a/src/CabalHelper/Compiletime/CompPrograms.hs b/src/CabalHelper/Compiletime/CompPrograms.hs new file mode 100644 index 0000000..020bab4 --- /dev/null +++ b/src/CabalHelper/Compiletime/CompPrograms.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE GADTs #-} + +module CabalHelper.Compiletime.CompPrograms where + +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 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 progs = do + let v = getCabalVerbosity + getMaybeProg' = getMaybeProg progs + progdb = + ProgDb.userMaybeSpecifyPath "ghc" (getMaybeProg' ghcProgram) $ + ProgDb.userMaybeSpecifyPath "ghc-pkg" (getMaybeProg' ghcPkgProgram) $ + ProgDb.userMaybeSpecifyPath "haddock" (getMaybeProg' haddockProgram) $ + ProgDb.defaultProgramDb + (_compiler, _mplatform, progdb1) <- GHC.configure v Nothing Nothing progdb + let Just haddockKnownProgram = ProgDb.lookupKnownProgram "haddock" progdb1 + progdb2 <- ProgDb.configureProgram v haddockKnownProgram progdb1 + let getProg p = ProgDb.programPath <$> ProgDb.lookupProgram p progdb2 + return progs + { ghcProgram = + fromMaybe (ghcProgram progs) $ getProg ProgDb.ghcProgram + , ghcPkgProgram = + fromMaybe (ghcPkgProgram progs) $ getProg ProgDb.ghcPkgProgram + , haddockProgram = + fromMaybe (haddockProgram progs) $ getProg ProgDb.haddockProgram + } + +getMaybeProg :: Programs -> (Programs -> FilePath) -> Maybe FilePath +getMaybeProg progs fn + | fn progs == fn defaultPrograms = Nothing + | otherwise = Just (fn progs) + +patchBuildToolProgs :: SProjType pt -> Programs -> IO Programs +patchBuildToolProgs (SCabal _) progs = return progs + { cabalUnitArgs = concat + [ maybeToList (("--with-ghc="++) <$> getMaybeProg progs ghcProgram) + , maybeToList (("--with-ghc-pkg="++) <$> getMaybeProg progs ghcPkgProgram) + , maybeToList (("--with-haddock="++) <$> getMaybeProg progs haddockProgram) + ] ++ cabalUnitArgs progs + } +patchBuildToolProgs SStack progs + -- optimization; if none of the program paths are non-default we don't + -- even have to add anything to PATH. + | ghcProgram progs == "ghc" + , ghcPkgProgram progs == "ghc-pkg" + , haddockProgram progs == "haddock" + = return progs + + -- optimization; if all paths are unqualified and have the same version + -- postfix Stack's default behaviour works for us. + | [ghc] <- splitPath (ghcProgram progs) + , [ghcPkg] <- splitPath (ghcPkgProgram progs) + , [haddock] <- splitPath (haddockProgram progs) + , Just ver <- stripPrefix "ghc-" ghc + , Just ver == stripPrefix "ghc-pkg-" ghcPkg + , Just ver == stripPrefix "haddock-" haddock + = return progs +patchBuildToolProgs SStack 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. + withSystemTempDirectory "cabal-helper-symlinks" $ \bindir -> do + createProgSymlink bindir $ ghcProgram progs + createProgSymlink bindir $ ghcPkgProgram progs + createProgSymlink bindir $ haddockProgram progs + return $ progs + { stackEnv = + [("PATH", EnvPrepend $ bindir ++ [searchPathSeparator])] ++ + stackEnv progs + } + +createProgSymlink :: FilePath -> FilePath -> IO () +createProgSymlink bindir target + | [exe] <- splitPath target = do + Just exe_path <- findExecutable exe + createSymbolicLink exe_path (bindir </> takeFileName target) + | otherwise = do + cwd <- getCurrentDirectory + createSymbolicLink (cwd </> target) (bindir </> takeFileName target) diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index 6591513..94e5c8e 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -562,12 +562,17 @@ data Programs = Programs , ghcPkgProgram :: !FilePath -- ^ The path to the @ghc-pkg@ program. If not changed it will be derived -- from the path to 'ghcProgram'. + + , haddockProgram :: !FilePath + -- ^ The path to the @haddock@ program. If not changed it will be + -- derived from the path to 'ghcProgram'. } deriving (Eq, Ord, Show, Read, Generic, Typeable) -- | By default all programs use their unqualified names, i.e. they will be -- searched for on @PATH@. defaultPrograms :: Programs -defaultPrograms = Programs "cabal" [] [] "stack" [] [] [] "ghc" "ghc-pkg" +defaultPrograms = + Programs "cabal" [] [] "stack" [] [] [] "ghc" "ghc-pkg" "haddock" data EnvOverride = EnvPrepend String diff --git a/tests/ProgramsTest.hs b/tests/ProgramsTest.hs new file mode 100644 index 0000000..467c1cc --- /dev/null +++ b/tests/ProgramsTest.hs @@ -0,0 +1,76 @@ +{-| This test checks if 'guessCompProgramPaths'\'s behaviour makes sense +-} + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +import Control.Monad +import Data.List +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.IO.Temp +import Text.Show.Pretty + +import CabalHelper.Compiletime.Types +import CabalHelper.Compiletime.CompPrograms +import Symlink (createSymbolicLink) + +main :: IO () +main = do + prog_name <- getProgName + args <- getArgs + case prog_name of + "programs-test" + | "ghc":ver:rest <- args -> ghc ver rest + | "ghc-pkg":ver:rest <- args -> ghc_pkg ver rest + | "haddock":ver:rest <- args -> haddock ver rest + | otherwise -> do_test + _ + | Just ver <- stripPrefix "ghc-pkg-" prog_name -> ghc_pkg ver args + | Just ver <- stripPrefix "ghc-" prog_name -> ghc ver args + | Just ver <- stripPrefix "haddock-" prog_name -> haddock ver args + where + ghc _ver ["--info"] = putStrLn "[]" -- seems we can get away with that :) + ghc ver ["--numeric-version"] = putStrLn ver + ghc _ver ["--supported-languages"] = return () + + ghc_pkg ver ["--version"] = + putStrLn $ "GHC package manager version " ++ ver + + haddock _ver ["--version"] = + putStrLn $ -- cabal isn't very picky about haddock versions so we just + -- hardocde it here + "Haddock version 2.20.0, (c) Simon Marlow 2006" ++ + "Ported to use the GHC API by David Waern 2006-2008" + +do_test :: IO () +do_test = do + prog <- canonicalizePath =<< getExecutablePath + + withSystemTempDirectory "c-h-programs-test" $ \tmpdir -> do + + forM_ ["8.6.5", "8.4.4"] $ \ver -> do + + let ghc = tmpdir </> "ghc-" ++ ver + let ghc_pkg = tmpdir </> "ghc-pkg-" ++ ver + let haddock = tmpdir </> "haddock-" ++ ver + let progs = defaultPrograms { ghcProgram = ghc } + + createSymbolicLink prog ghc + createSymbolicLink prog ghc_pkg + createSymbolicLink prog haddock + + let ?verbose = (==4) + + progs' <- guessCompProgramPaths progs + + pPrint (ghc, ghc_pkg, haddock) -- expected + pPrint progs' -- actual + + when (not $ and [ ghcPkgProgram progs' == ghc_pkg + , haddockProgram progs' == haddock + ]) + exitFailure + + putStr "\n\n" |