Paths.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StrictData #-}
module Cabal.Paths (
  Paths(..)
, paths
) where

import           Imports

import           Data.Char
import           Data.Tuple
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

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

paths :: FilePath -> [String] -> IO Paths
paths cabal args = do
  cabalVersion <- strip <$> readProcess cabal ["--numeric-version"] ""

  let
    required :: Version
    required = makeVersion [3, 12]

  when (parseVersion cabalVersion < Just required) $ do
    die $ "'cabal-install' version " <> showVersion required <> " or later is required, but 'cabal --numeric-version' returned " <> cabalVersion <> "."

  values <- parseFields <$> readProcess cabal ("path" : args ++ ["-v0"]) ""

  let
    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 <- getPath "'ghc'" "compiler-path"

  ghcVersionString <- strip <$> readProcess ghc ["--numeric-version"] ""

  ghcVersion <- case parseVersion ghcVersionString of
    Nothing -> die $ "Cannot determine GHC version from '" <> ghcVersionString <> "'."
    Just version -> return version

  let
    ghcPkg :: FilePath
    ghcPkg = takeDirectory ghc </> "ghc-pkg-" <> ghcVersionString
#ifdef mingw32_HOST_OS
      <.> "exe"
#endif

  doesFileExist ghcPkg >>= \ case
    True -> pass
    False -> die $ "Cannot determine the path to 'ghc-pkg' from '" <> ghc <> "'. File '" <> ghcPkg <> "' does not exist."

  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" </> "ghc-" <> ghcVersionString <> "-" <> abi

  createDirectoryIfMissing True cache

  return Paths {
    ghcVersion
  , ghc
  , ghcPkg
  , cache
  }
  where
    parseFields :: String -> [(String, FilePath)]
    parseFields = map parseField . lines

    parseField :: String -> (String, FilePath)
    parseField input = case break (== ':') input of
      (key, ':' : value) -> (key, dropWhile isSpace value)
      (key, _) -> (key, "")

die :: String -> IO a
die message = do
  hPutStrLn stderr "Error: [cabal-doctest]"
  hPutStrLn stderr message
  exitFailure

parseVersion :: String -> Maybe Version
parseVersion = lookup "" . map swap . readP_to_S Version.parseVersion