Skip to content

Commit

Permalink
cabal-doctest: Cache doctest executables
Browse files Browse the repository at this point in the history
  • Loading branch information
sol committed Jul 16, 2024
1 parent 1f07492 commit 5a4a8ef
Show file tree
Hide file tree
Showing 5 changed files with 55 additions and 26 deletions.
2 changes: 0 additions & 2 deletions doctest.cabal

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

1 change: 0 additions & 1 deletion package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -65,7 +65,6 @@ library:
ghc-paths: ">= 0.1.0.9"
Cabal:
transformers:
temporary:

flags:
cabal-doctest:
Expand Down
51 changes: 34 additions & 17 deletions src/Cabal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,10 +3,11 @@ module Cabal (externalCommand) where

import Imports

import System.IO
import System.Environment
import System.Exit (exitWith)
import System.Directory
import System.FilePath
import System.IO.Temp (withSystemTempDirectory)
import System.Process

import qualified Info
Expand All @@ -19,30 +20,46 @@ externalCommand args = do
Just cabal -> run cabal (drop 1 args)

run :: String -> [String] -> IO ()
run cabal args = withSystemTempDirectory "doctest" $ \ dir -> do
let
doctest = dir </> "doctest"
script = dir </> "init-ghci"
run cabal args = do

Paths{..} <- paths cabal

callProcess cabal [
"install" , "doctest-" <> Info.version
, "--flag", "-cabal-doctest"
, "--ignore-project"
, "--installdir", dir
, "--install-method=symlink"
, "--with-compiler", ghc
, "--with-hc-pkg", ghcPkg
]

callProcess (dir </> "doctest") ["--version"]
let
doctest = cache </> "doctest" <> "-" <> Info.version
script = cache </> "init-ghci-" <> Info.version

doesFileExist doctest >>= \ case
True -> pass
False -> callProcess cabal [
"install" , "doctest-" <> Info.version
, "--flag", "-cabal-doctest"
, "--ignore-project"
, "--installdir", cache
, "--program-suffix", "-" <> Info.version
, "--install-method=copy"
, "--with-compiler", ghc
, "--with-hc-pkg", ghcPkg
]

doesFileExist script >>= \ case
True -> pass
False -> writeFileAtomically script ":seti -w -Wdefault"

callProcess doctest ["--version"]

callProcess cabal ("build" : "--only-dependencies" : args)
writeFile script ":seti -w -Wdefault"

spawnProcess cabal ("repl"
: "--build-depends=QuickCheck"
: "--build-depends=template-haskell"
: ("--repl-options=-ghci-script=" <> script)
: "--with-compiler" : doctest
: "--with-hc-pkg" : ghcPkg
: args) >>= waitForProcess >>= exitWith

writeFileAtomically :: FilePath -> String -> IO ()
writeFileAtomically name contents = do
(tmp, h) <- openTempFile (takeDirectory name) (takeFileName name)
hPutStr h contents
hClose h
renameFile tmp name
24 changes: 18 additions & 6 deletions src/Cabal/Paths.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,7 @@ import Data.Version hiding (parseVersion)
import qualified Data.Version as Version
import System.Exit hiding (die)
import System.Directory
import System.FilePath
import System.IO
import System.Process
import Text.ParserCombinators.ReadP
Expand All @@ -20,10 +21,12 @@ import qualified Distribution.Simple.GHC as GHC
import Distribution.Verbosity
import Distribution.Simple.Program.Db
import Distribution.Simple.Program.Types
import Distribution.Simple.Compiler

data Paths = Paths {
ghc :: FilePath
, ghcPkg :: FilePath
, cache :: FilePath
} deriving (Eq, Show)

paths :: FilePath -> IO Paths
Expand All @@ -40,22 +43,31 @@ paths cabal = do
values <- parseFields <$> readProcess cabal ["path", "-v0"] ""

let
compiler_path :: String
compiler_path = "compiler-path"
getPath :: String -> String -> IO FilePath
getPath subject key = case lookup key values of
Nothing -> die $ "Cannot determine the path to " <> subject <> ". Running 'cabal path' did not return a value for '" <> key <> "'."
Just path -> canonicalizePath path

ghc <- case lookup compiler_path values of
Nothing -> die $ "Cannot determine the path to 'ghc'. Running 'cabal path' did not return a value for '" <> compiler_path <> "'."
Just path -> canonicalizePath path
ghc <- getPath "'ghc'" "compiler-path"

(compiler, _, programs) <- GHC.configure silent (Just ghc) Nothing emptyProgramDb

(_, _, programs) <- GHC.configure silent (Just ghc) Nothing emptyProgramDb

ghcPkg <- case programPath <$> List.find (programId >>> (== "ghc-pkg")) (configuredPrograms programs) of
Nothing -> die $ "Cannot determine the path to 'ghc-pkg' from '" <> ghc <> "'."
Just path -> return path

abi <- strip <$> readProcess ghcPkg ["--no-user-package-db", "field", "base", "abi", "--simple-output"] ""

cache_home <- getPath "Cabal's cache directory" "cache-home"
let cache = cache_home </> "doctest" </> showCompilerId compiler <> "-" <> abi

createDirectoryIfMissing True cache

return Paths {
ghc
, ghcPkg
, cache
}
where
parseFields :: String -> [(String, FilePath)]
Expand Down
3 changes: 3 additions & 0 deletions test/Cabal/PathsSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -16,3 +16,6 @@ spec = do

it "returns the path to 'ghc-pkg'" $ do
(paths "cabal" >>= doesFileExist . ghcPkg) `shouldReturn` True

it "returns the path to Cabal's cache directory" $ do
(paths "cabal" >>= doesDirectoryExist . cache) `shouldReturn` True

0 comments on commit 5a4a8ef

Please sign in to comment.