module HIE.Bios.Cradle.Utils
  (
  -- * Helper for process errors
    ProcessErrorDetails(..)
  , prettyProcessErrorDetails
  -- * Cradle utils
  , selectCradle
  -- * Processing of ghc-options
  , removeInteractive
  , removeRTS
  , removeVerbosityOpts
  , expandGhcOptionResponseFile
  )
  where

import HIE.Bios.Types (prettyCmdSpec)

import Data.List
import System.Process.Extra
import GHC.ResponseFile (expandResponse)

-- ----------------------------------------------------------------------------
-- Process error details
-- ----------------------------------------------------------------------------

data ProcessErrorDetails = ProcessErrorDetails
  { ProcessErrorDetails -> CmdSpec
processCmd :: CmdSpec
  -- ^ The 'CmdSpec' of the command.
  , ProcessErrorDetails -> [String]
processStdout :: [String]
  -- ^ The stdout of the command.
  , ProcessErrorDetails -> [String]
processStderr :: [String]
  -- ^ The stderr of the command.
  , ProcessErrorDetails -> [String]
processGhcOptions :: [String]
  -- ^ The ghc-options that were obtained via the command
  , ProcessErrorDetails -> [(String, String)]
processHieBiosEnvironment :: [(String, String)]
  -- ^ Environment variables populated by 'hie-bios' and their respective value.
  }

prettyProcessErrorDetails :: ProcessErrorDetails -> [String]
prettyProcessErrorDetails :: ProcessErrorDetails -> [String]
prettyProcessErrorDetails ProcessErrorDetails
p  =
  [ String
"Failed command: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CmdSpec -> String
prettyCmdSpec (ProcessErrorDetails -> CmdSpec
processCmd ProcessErrorDetails
p),
    [String] -> String
unlines (ProcessErrorDetails -> [String]
processStdout ProcessErrorDetails
p),
    [String] -> String
unlines (ProcessErrorDetails -> [String]
processStderr ProcessErrorDetails
p),
    [String] -> String
unlines (ProcessErrorDetails -> [String]
processGhcOptions ProcessErrorDetails
p),
    String
"Process Environment:"
  ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [ String
key String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
value
  | (String
key, String
value) <- ProcessErrorDetails -> [(String, String)]
processHieBiosEnvironment ProcessErrorDetails
p
  ]

-- ----------------------------------------------------------------------------
-- Cradle utils
-- ----------------------------------------------------------------------------

-- | Given a list of cradles, try to find the most likely cradle that
-- this 'FilePath' belongs to.
selectCradle :: (a -> FilePath) -> FilePath -> [a] -> Maybe a
selectCradle :: forall a. (a -> String) -> String -> [a] -> Maybe a
selectCradle a -> String
_ String
_ [] = Maybe a
forall a. Maybe a
Nothing
selectCradle a -> String
k String
cur_fp (a
c: [a]
css) =
    if a -> String
k a
c String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
cur_fp
      then a -> Maybe a
forall a. a -> Maybe a
Just a
c
      else (a -> String) -> String -> [a] -> Maybe a
forall a. (a -> String) -> String -> [a] -> Maybe a
selectCradle a -> String
k String
cur_fp [a]
css


-- ----------------------------------------------------------------------------
-- Cradle utils
-- ----------------------------------------------------------------------------

removeInteractive :: [String] -> [String]
removeInteractive :: [String] -> [String]
removeInteractive = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"--interactive")

-- | Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.
data InRTS = OutsideRTS | InsideRTS

-- | Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.
--
-- >>> removeRTS ["option1", "+RTS -H32m -RTS", "option2"]
-- ["option1", "option2"]
--
-- >>> removeRTS ["option1", "+RTS", "-H32m", "-RTS", "option2"]
-- ["option1", "option2"]
--
-- >>> removeRTS ["option1", "+RTS -H32m"]
-- ["option1"]
--
-- >>> removeRTS ["option1", "+RTS -H32m", "-RTS", "option2"]
-- ["option1", "option2"]
--
-- >>> removeRTS ["option1", "+RTS -H32m", "-H32m -RTS", "option2"]
-- ["option1", "option2"]
removeRTS :: [String] -> [String]
removeRTS :: [String] -> [String]
removeRTS = InRTS -> [String] -> [String]
go InRTS
OutsideRTS
  where
    go :: InRTS -> [String] -> [String]
    go :: InRTS -> [String] -> [String]
go InRTS
_ [] = []
    go InRTS
OutsideRTS (String
y:[String]
ys)
      | String
"+RTS" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
y = InRTS -> [String] -> [String]
go (if String
"-RTS" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
y then InRTS
OutsideRTS else InRTS
InsideRTS) [String]
ys
      | Bool
otherwise = String
y String -> [String] -> [String]
forall a. a -> [a] -> [a]
: InRTS -> [String] -> [String]
go InRTS
OutsideRTS [String]
ys
    go InRTS
InsideRTS (String
y:[String]
ys) = InRTS -> [String] -> [String]
go (if String
"-RTS" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
y then InRTS
OutsideRTS else InRTS
InsideRTS) [String]
ys


removeVerbosityOpts :: [String] -> [String]
removeVerbosityOpts :: [String] -> [String]
removeVerbosityOpts = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> (String -> Bool) -> String -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"-v0") (String -> Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall a b. (String -> a -> b) -> (String -> a) -> String -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"-w"))

expandGhcOptionResponseFile :: [String] -> IO [String]
expandGhcOptionResponseFile :: [String] -> IO [String]
expandGhcOptionResponseFile [String]
args = do
  [String]
expanded_args <- [String] -> IO [String]
expandResponse [String]
args
  [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
removeInteractive [String]
expanded_args