{-# 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
  String
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 :: Version
required = [Int] -> Version
makeVersion [Int
3, Int
12]

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Maybe Version
parseVersion String
cabalVersion Maybe Version -> Maybe Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version -> Maybe Version
forall a. a -> Maybe a
Just Version
required) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"'cabal-install' version " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
required String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" or later is required, but 'cabal --numeric-version' returned " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
cabalVersion String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."

  [(String, String)]
values <- String -> [(String, String)]
parseFields (String -> [(String, String)])
-> IO String -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
cabal (String
"path" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-v0"]) String
""

  let
    getPath :: String -> String -> IO FilePath
    getPath :: String -> String -> IO String
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

  String
ghc <- String -> String -> IO String
getPath String
"'ghc'" String
"compiler-path"

  String
ghcVersionString <- 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
ghc [String
"--numeric-version"] String
""

  Version
ghcVersion <- case String -> Maybe Version
parseVersion String
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 :: String
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

  String -> IO Bool
doesFileExist String
ghcPkg IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ 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."

  String
abi <- 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
ghcPkg [String
"--no-user-package-db", String
"field", String
"base", String
"abi", String
"--simple-output"] String
""

  String
cache_home <- String -> String -> IO String
getPath String
"Cabal's cache directory" String
"cache-home"
  let cache :: String
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

  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cache

  Paths -> IO Paths
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Paths {
    Version
ghcVersion :: Version
ghcVersion :: Version
ghcVersion
  , String
ghc :: String
ghc :: String
ghc
  , String
ghcPkg :: String
ghcPkg :: String
ghcPkg
  , String
cache :: String
cache :: String
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