{-# 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 {
  Paths -> Version
ghcVersion :: Version
, Paths -> [Char]
ghc  :: FilePath
, Paths -> [Char]
ghcPkg :: FilePath
, Paths -> [Char]
cache :: FilePath
} deriving (Paths -> Paths -> Bool
(Paths -> Paths -> Bool) -> (Paths -> Paths -> Bool) -> Eq Paths
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Paths -> Paths -> Bool
== :: Paths -> Paths -> Bool
$c/= :: Paths -> Paths -> Bool
/= :: Paths -> Paths -> Bool
Eq, Int -> Paths -> ShowS
[Paths] -> ShowS
Paths -> [Char]
(Int -> Paths -> ShowS)
-> (Paths -> [Char]) -> ([Paths] -> ShowS) -> Show Paths
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Paths -> ShowS
showsPrec :: Int -> Paths -> ShowS
$cshow :: Paths -> [Char]
show :: Paths -> [Char]
$cshowList :: [Paths] -> ShowS
showList :: [Paths] -> ShowS
Show)

paths :: FilePath -> [String] -> IO Paths
paths :: [Char] -> [[Char]] -> IO Paths
paths [Char]
cabal [[Char]]
args = do
  cabalVersion <- ShowS
strip ShowS -> IO [Char] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [[Char]] -> [Char] -> IO [Char]
readProcess [Char]
cabal [[Char]
"--numeric-version"] [Char]
""

  let
    required :: Version
    required = [Int] -> Version
makeVersion [Int
3, Int
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 [Char]
subject [Char]
key = case [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
key [([Char], [Char])]
values of
      Maybe [Char]
Nothing -> [Char] -> IO [Char]
forall a. [Char] -> IO a
die ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot determine the path to " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
subject [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
". Running 'cabal path' did not return a value for '" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
key [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"'."
      Just [Char]
path -> [Char] -> IO [Char]
canonicalizePath [Char]
path

  ghc <- getPath "'ghc'" "compiler-path"

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

  ghcVersion <- case parseVersion ghcVersionString of
    Maybe Version
Nothing -> [Char] -> IO Version
forall a. [Char] -> IO a
die ([Char] -> IO Version) -> [Char] -> IO Version
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot determine GHC version from '" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
ghcVersionString [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"'."
    Just Version
version -> Version -> IO Version
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Version
version

  let
    ghcPkg :: FilePath
    ghcPkg = ShowS
takeDirectory [Char]
ghc [Char] -> ShowS
</> [Char]
"ghc-pkg-" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
ghcVersionString
#ifdef mingw32_HOST_OS
      <.> "exe"
#endif

  doesFileExist ghcPkg >>= \ case
    Bool
True -> IO ()
forall (m :: * -> *). Monad m => m ()
pass
    Bool
False -> [Char] -> IO ()
forall a. [Char] -> IO a
die ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot determine the path to 'ghc-pkg' from '" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
ghc [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"'. File '" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
ghcPkg [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"' 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 = [Char]
cache_home [Char] -> ShowS
</> [Char]
"doctest" [Char] -> ShowS
</> [Char]
"ghc-" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
ghcVersionString [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"-" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
abi

  createDirectoryIfMissing True cache

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

    parseField :: String -> (String, FilePath)
    parseField :: [Char] -> ([Char], [Char])
parseField [Char]
input = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') [Char]
input of
      ([Char]
key, Char
':' : [Char]
value) -> ([Char]
key, (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
value)
      ([Char]
key, [Char]
_) -> ([Char]
key, [Char]
"")

die :: String -> IO a
die :: forall a. [Char] -> IO a
die [Char]
message = do
  Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"Error: [cabal-doctest]"
  Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
message
  IO a
forall a. IO a
exitFailure

parseVersion :: String -> Maybe Version
parseVersion :: [Char] -> Maybe Version
parseVersion = [Char] -> [([Char], Version)] -> Maybe Version
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"" ([([Char], Version)] -> Maybe Version)
-> ([Char] -> [([Char], Version)]) -> [Char] -> Maybe Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Version, [Char]) -> ([Char], Version))
-> [(Version, [Char])] -> [([Char], Version)]
forall a b. (a -> b) -> [a] -> [b]
map (Version, [Char]) -> ([Char], Version)
forall a b. (a, b) -> (b, a)
swap ([(Version, [Char])] -> [([Char], Version)])
-> ([Char] -> [(Version, [Char])]) -> [Char] -> [([Char], Version)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadP Version -> [Char] -> [(Version, [Char])]
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
Version.parseVersion