{-# LANGUAGE LambdaCase #-}
module Cabal (externalCommand) where

import           Imports

import           Data.List
import           Data.Version (makeVersion)
import           System.IO
import           System.IO.Temp
import           System.Environment
import           System.Directory
import           System.FilePath
import           System.Process

import qualified Info
import           Cabal.Paths
import           Cabal.Options

externalCommand :: [String] -> IO ()
externalCommand :: [String] -> IO ()
externalCommand [String]
args = do
  String -> IO (Maybe String)
lookupEnv String
"CABAL" IO (Maybe String) -> (Maybe String -> 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
    Maybe String
Nothing -> String -> [String] -> IO ()
run String
"cabal" [String]
args
    Just String
cabal -> String -> [String] -> IO ()
run String
cabal (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 [String]
args)

run :: String -> [String] -> IO ()
run :: String -> [String] -> IO ()
run String
cabal [String]
args = do
  [String] -> IO ()
rejectUnsupportedOptions [String]
args

  Paths{String
Version
ghcVersion :: Version
ghc :: String
ghcPkg :: String
cache :: String
ghcVersion :: Paths -> Version
ghc :: Paths -> String
ghcPkg :: Paths -> String
cache :: Paths -> String
..} <- String -> [String] -> IO Paths
paths String
cabal ([String] -> [String]
discardReplOptions [String]
args)

  let
    doctest :: String
doctest = String
cache String -> String -> String
</> String
"doctest" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
Info.version
    script :: String
script = String
cache String -> String -> String
</> String
"init-ghci-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
Info.version

  String -> IO Bool
doesFileExist String
doctest 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 -> [String] -> IO ()
callProcess String
cabal [
        String
"install" , String
"doctest-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
Info.version
      , String
"--flag", String
"-cabal-doctest"
      , String
"--ignore-project"
      , String
"--installdir", String
cache
      , String
"--program-suffix", String
"-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
Info.version
      , String
"--install-method=copy"
      , String
"--with-compiler", String
ghc
      ]

  String -> IO Bool
doesFileExist String
script 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 -> String -> IO ()
writeFileAtomically String
script String
":seti -w -Wdefault"

  String -> [String] -> IO ()
callProcess String
doctest [String
"--version"]

  let
    repl :: [String] -> IO ()
repl [String]
extraArgs = String -> [String] -> IO ()
call String
cabal (String
"repl"
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--build-depends=QuickCheck"
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--build-depends=template-haskell"
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String
"--repl-options=-ghci-script=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
script)
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extraArgs)

  case Version
ghcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
makeVersion [Int
9,Int
4] of
    Bool
True -> do
      String -> [String] -> IO ()
callProcess String
cabal (String
"build" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--only-dependencies" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
discardReplOptions [String]
args)
      [String] -> IO ()
repl [String
"--with-compiler", String
doctest, String
"--with-hc-pkg", String
ghcPkg]

    Bool
False -> do
      String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"cabal-doctest" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ String
dir -> do
        [String] -> IO ()
repl [String
"--keep-temp-files", String
"--repl-multi-file", String
dir]
        [String]
files <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
"-inplace") ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
dir
        [String]
options <- [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((String -> [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
lines (IO String -> IO [String])
-> (String -> IO String) -> String -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile (String -> IO String) -> (String -> String) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
combine String
dir) [String]
files
        String -> [String] -> IO ()
call String
doctest (String
"--no-magic" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
options)

writeFileAtomically :: FilePath -> String -> IO ()
writeFileAtomically :: String -> String -> IO ()
writeFileAtomically String
name String
contents = do
  (String
tmp, Handle
h) <- String -> String -> IO (String, Handle)
openTempFile (String -> String
takeDirectory String
name) (String -> String
takeFileName String
name)
  Handle -> String -> IO ()
hPutStr Handle
h String
contents
  Handle -> IO ()
hClose Handle
h
  String -> String -> IO ()
renameFile String
tmp String
name