{-# 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 -> String
ghc  :: FilePath
, Paths -> String
ghcPkg :: FilePath
, Paths -> String
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 -> String
(Int -> Paths -> ShowS)
-> (Paths -> String) -> ([Paths] -> ShowS) -> Show Paths
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Paths -> ShowS
showsPrec :: Int -> Paths -> ShowS
$cshow :: Paths -> String
show :: Paths -> String
$cshowList :: [Paths] -> ShowS
showList :: [Paths] -> ShowS
Show)

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

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

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

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

  ghcVersion <- case parseVersion ghcVersionString of
    Maybe Version
Nothing -> String -> IO Version
forall a. String -> IO a
die (String -> IO Version) -> String -> IO Version
forall a b. (a -> b) -> a -> b
$ String
"Cannot determine GHC version from '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ghcVersionString String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'."
    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 String
ghc String -> ShowS
</> String
"ghc-pkg-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ghcVersionString
#ifdef mingw32_HOST_OS
      <.> "exe"
#endif

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

  createDirectoryIfMissing True cache

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

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

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

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