-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE OverloadedStrings #-}
module Shake.Util (
    -- * shake specific
    Cmdline, cmdline, system, systemKeepGoing, shell
    , findFiles, findHs, runIO

    -- * ghc
    , PackageId(..)
    , readGhcEnvironment
    -- * platform
    , Platform(..), platform
    -- * general
    , ifM, whenM, errorIO
) where
import qualified Control.Concurrent.Async as Async
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Exception as Exception
import qualified Control.Monad.Trans as Trans
import           Control.Monad.Trans (liftIO)

import qualified Data.Char as Char
import qualified Data.Either as Either
import qualified Data.Function as Function
import qualified Data.IORef as IORef
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import           Data.Text (Text)
import qualified Data.Text.IO as Text.IO
import qualified Data.Time as Time

import qualified Development.Shake as Shake
import qualified Development.Shake.FilePath as FilePath
import qualified System.CPUTime as CPUTime
import qualified System.Console.Concurrent as Concurrent
import qualified System.Console.Regions as Regions
import qualified System.Directory as Directory
import qualified System.Exit as Exit
import qualified System.FilePath
import           System.FilePath ((</>))
import qualified System.IO as IO
import qualified System.Info
import qualified System.Process as Process

import qualified Text.Printf as Printf

import qualified Util.Exceptions as Exceptions

import           Control.Monad


-- * shake specific

-- | (short_name_for_cmd, output_file_name, [cmd])
type Cmdline = (String, String, [String])

-- | This is like 'system', but expect a Cmdline.  It logs an abbreviated
-- cmdline at quiet, and a complete cmdline at normal.
--
-- Shake logs @# key@ msgs at and cmds at loud.  However, I think cmds should
-- be at normal, and the keys should be at loud, because the cmds give
-- a progress indication, while the keys just make any compiler errors scroll
-- off the screen.
cmdline :: Cmdline -> Shake.Action ()
cmdline :: Cmdline -> Action ()
cmdline cmd :: Cmdline
cmd@([Char]
abbr, [Char]
_, [[Char]]
cmdline) = do
    Bool
fancy <- Action Bool
fancyOutput
    [Char] -> Action ()
Shake.putNormal forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords forall a b. (a -> b) -> a -> b
$ [Char]
"%" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
quote [[Char]]
cmdline
    forall a. [Char] -> IO a -> Action a
Shake.traced ([Char]
"cmdline:" forall a. Semigroup a => a -> a -> a
<> [Char]
abbr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Cmdline -> IO ()
doCmdline Bool
fancy Bool
False Cmdline
cmd

quote :: String -> String
quote :: [Char] -> [Char]
quote [Char]
w
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
w) ([Char]
"\" " :: [Char]) = Char
'\'' forall a. a -> [a] -> [a]
: [Char]
w forall a. [a] -> [a] -> [a]
++ [Char]
"'"
    | Bool
otherwise = [Char]
w

data Metric = Metric {
    Metric -> Double
metricCpu :: !Double
    , Metric -> UTCTime
metricWall :: !Time.UTCTime
    } deriving (Int -> Metric -> [Char] -> [Char]
[Metric] -> [Char] -> [Char]
Metric -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Metric] -> [Char] -> [Char]
$cshowList :: [Metric] -> [Char] -> [Char]
show :: Metric -> [Char]
$cshow :: Metric -> [Char]
showsPrec :: Int -> Metric -> [Char] -> [Char]
$cshowsPrec :: Int -> Metric -> [Char] -> [Char]
Show)

metric :: IO Metric
metric :: IO Metric
metric = Double -> UTCTime -> Metric
Metric forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall {a} {a}. (Fractional a, Integral a) => a -> a
cpuToSec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Integer
CPUTime.getCPUTime) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO UTCTime
Time.getCurrentTime
    where cpuToSec :: a -> a
cpuToSec a
s = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
s forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
10forall a b. (Num a, Integral b) => a -> b -> a
^Integer
12)

diffMetric :: Metric -> Metric -> String
diffMetric :: Metric -> Metric -> [Char]
diffMetric (Metric Double
_cpu1 UTCTime
time1) (Metric Double
_cpu2 UTCTime
time2) =
    -- I used to print the cpu time too, but it's always really low.
    forall r. PrintfType r => [Char] -> r
Printf.printf [Char]
"%.2fs" (NominalDiffTime -> Double
toSecs (UTCTime
time1 UTCTime -> UTCTime -> NominalDiffTime
`Time.diffUTCTime` UTCTime
time2))
    where
    toSecs :: Time.NominalDiffTime -> Double
    toSecs :: NominalDiffTime -> Double
toSecs = forall a b. (Real a, Fractional b) => a -> b
realToFrac

-- | If true, use concurrent output, otherwise use shake's default output.
fancyOutput :: Shake.Action Bool
fancyOutput :: Action Bool
fancyOutput = (forall a. Ord a => a -> a -> Bool
<=Verbosity
Shake.Warn) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action Verbosity
Shake.getVerbosity

doCmdline :: Bool -> Bool -> Cmdline -> IO ()
doCmdline :: Bool -> Bool -> Cmdline -> IO ()
doCmdline Bool
_ Bool
_ ([Char]
abbr, [Char]
output, []) =
    forall (m :: * -> *) a. MonadIO m => [Char] -> m a
errorIO forall a b. (a -> b) -> a -> b
$ [Char]
"0 args for cmdline: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ([Char]
abbr, [Char]
output)
doCmdline Bool
fancyOutput Bool
keepGoing ([Char]
abbr, [Char]
output, [Char]
cmd_:[[Char]]
args) = do
    Metric
start <- IO Metric
metric
    Bool
notRequired <- forall {m :: * -> *} {a}.
(MonadIO m, MonadMask m, LiftRegion m) =>
m a -> m a
withRegion (do
        (ExitCode
exit, Bool
ghcNotRequired) <- [Char] -> [[Char]] -> IO (ExitCode, Bool)
createProcessConcurrent [Char]
"nice" ([Char]
cmdforall a. a -> [a] -> [a]
:[[Char]]
args)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
keepGoing Bool -> Bool -> Bool
&& ExitCode
exit forall a. Eq a => a -> a -> Bool
/= ExitCode
Exit.ExitSuccess) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a. MonadIO m => [Char] -> m a
errorIO forall a b. (a -> b) -> a -> b
$ [Char]
"Failed:\n"
                forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
ellipsis Int
80 ([[Char]] -> [Char]
unwords (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
quote ([Char]
cmd forall a. a -> [a] -> [a]
: [[Char]]
args)))
        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ghcNotRequired
        ) forall a b. IO a -> IO b -> IO a
`Exception.onException` do
            [Char]
timing <- Metric -> IO [Char]
showMetric Metric
start
            [Char] -> IO ()
put forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
desc, [Char]
timing, [Char]
"(aborted)"]
    [Char]
timing <- Metric -> IO [Char]
showMetric Metric
start
    [Char] -> IO ()
put forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
desc, [Char]
timing] forall a. Semigroup a => a -> a -> a
<> (if Bool
notRequired then [Char]
" (skipped)" else [Char]
"")
    where
    showMetric :: Metric -> IO [Char]
showMetric Metric
start = do
        Metric
end <- IO Metric
metric
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
"-", Metric -> Metric -> [Char]
diffMetric Metric
end Metric
start]
    cmd :: [Char]
cmd = [Char] -> [Char]
FilePath.toNative [Char]
cmd_
    desc :: [Char]
desc = Int -> [Char] -> [Char]
ellipsis Int
127 [Char]
abbr forall a. Semigroup a => a -> a -> a
<> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
output then [Char]
"" else [Char]
": " forall a. Semigroup a => a -> a -> a
<> [Char]
output
    put :: [Char] -> IO ()
put | Bool
fancyOutput = forall v. Outputable v => v -> IO ()
Concurrent.outputConcurrent forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<>[Char]
"\n")
        | Bool
otherwise = [Char] -> IO ()
putStrLn
    withRegion :: m a -> m a
withRegion m a
action
        | Bool
fancyOutput = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RegionLayout -> (ConsoleRegion -> m a) -> m a
Regions.withConsoleRegion RegionLayout
Regions.Linear forall a b. (a -> b) -> a -> b
$ \ConsoleRegion
region -> do
            forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Regions.setConsoleRegion ConsoleRegion
region [Char]
desc
            m a
action
        | Bool
otherwise = m a
action

-- | Some command lines are really long.
ellipsis :: Int -> String -> String
ellipsis :: Int -> [Char] -> [Char]
ellipsis Int
len [Char]
line
    | Int
lineLen forall a. Ord a => a -> a -> Bool
> Int
len = forall a. Int -> [a] -> [a]
take Int
len [Char]
line forall a. Semigroup a => a -> a -> a
<> [Char]
"... [" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
lineLen forall a. Semigroup a => a -> a -> a
<> [Char]
" chars]"
    | Bool
otherwise = [Char]
line
    where lineLen :: Int
lineLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
line

-- | This is basically like 'Concurrent.createProcessConcurrent', except that
-- one doesn't get along with ghc's colorized stderr, for some reason.  I tried
-- to see why, but its implementation is crazy complicated due to it wanting
-- to buffer in temp files if the output is too large.
createProcessConcurrent :: FilePath -> [String] -> IO (Exit.ExitCode, Bool)
createProcessConcurrent :: [Char] -> [[Char]] -> IO (ExitCode, Bool)
createProcessConcurrent [Char]
cmd [[Char]]
args = do
    let proc :: CreateProcess
proc = ([Char] -> [[Char]] -> CreateProcess
Process.proc [Char]
cmd [[Char]]
args)
            { std_in :: StdStream
Process.std_in = StdStream
Process.NoStream
            , std_out :: StdStream
Process.std_out = StdStream
Process.CreatePipe
            , std_err :: StdStream
Process.std_err = StdStream
Process.CreatePipe
            }
    IORef Bool
ghcNotRequired <- forall a. a -> IO (IORef a)
IORef.newIORef Bool
False
    forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
proc forall a b. (a -> b) -> a -> b
$ \Maybe Handle
Nothing (Just Handle
outh) (Just Handle
errh) ProcessHandle
pid -> do
        Async ()
outWriter <- forall a. IO a -> IO (Async a)
Async.async (IORef Bool -> Handle -> IO ()
streamHandle IORef Bool
ghcNotRequired Handle
outh)
        Async ()
errWriter <- forall a. IO a -> IO (Async a)
Async.async (IORef Bool -> Handle -> IO ()
streamHandle IORef Bool
ghcNotRequired Handle
errh)
        forall a. Async a -> IO a
Async.wait Async ()
outWriter
        forall a. Async a -> IO a
Async.wait Async ()
errWriter
        (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
pid forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IORef a -> IO a
IORef.readIORef IORef Bool
ghcNotRequired
    where
    streamHandle :: IORef Bool -> Handle -> IO ()
streamHandle IORef Bool
ghcNotRequired Handle
hdl = forall a. (a -> a) -> a
Function.fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop ->
        forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEOF (Handle -> IO Text
Text.IO.hGetLine Handle
hdl) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Text
x -> case Maybe Text
x of
            Maybe Text
Nothing -> Handle -> IO ()
IO.hClose Handle
hdl
            Just Text
line -> do
                -- This shows up on ghc's stdout.
                if Text
line forall a. Eq a => a -> a -> Bool
== Text
"compilation IS NOT required"
                    then forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef Bool
ghcNotRequired Bool
True
                    else if Text -> Bool
ignoreLine Text
line then forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else forall v. Outputable v => v -> IO ()
Concurrent.outputConcurrent (Text
line forall a. Semigroup a => a -> a -> a
<> Text
"\n")
                IO ()
loop
    ignoreLine :: Text -> Bool
ignoreLine Text
line =
        -- A bug in OS X 10.13.6 causes harmless but annoying warnings.
        -- This is supposedly a solution:
        -- https://gist.github.com/wawiesel/eba461de5f5e38f7f0ac93ae3676b484
        -- No solution from Apple as of 2019-03-09:
        -- https://github.com/golang/go/issues/26073
        --
        -- It seems simpler and safer to just ignore it.
        Text
"ld: warning: text-based stub file " Text -> Text -> Bool
`Text.isPrefixOf` Text
line
        -- For some reason I get this on darwin + nix, but only with ghc -fhpc.
        -- No desire to dig into it.
        Bool -> Bool -> Bool
|| Text
"libiconv.dylib, ignoring unexpected dylib file" Text -> Text -> Bool
`Text.isSuffixOf` Text
line

system :: FilePath -> [String] -> Shake.Action ()
system :: [Char] -> [[Char]] -> Action ()
system [Char]
cmd [[Char]]
args = Cmdline -> Action ()
cmdline ([[Char]] -> [Char]
unwords ([Char]
cmdforall a. a -> [a] -> [a]
:[[Char]]
args), [Char]
"", [Char]
cmdforall a. a -> [a] -> [a]
:[[Char]]
args)

-- | Like 'system', but don't ignore the exit code.
systemKeepGoing :: FilePath -> [String] -> Shake.Action ()
systemKeepGoing :: [Char] -> [[Char]] -> Action ()
systemKeepGoing [Char]
cmd [[Char]]
args = do
    Bool
fancy <- Action Bool
fancyOutput
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Cmdline -> IO ()
doCmdline Bool
fancy Bool
True ([[Char]] -> [Char]
unwords ([Char]
cmdforall a. a -> [a] -> [a]
:[[Char]]
args), [Char]
"", [Char]
cmdforall a. a -> [a] -> [a]
:[[Char]]
args)

-- | Run a shell command, and crash if it fails.
shell :: String -> Shake.Action ()
shell :: [Char] -> Action ()
shell [Char]
cmd = do
    [Char] -> Action ()
Shake.putNormal [Char]
cmd
    ExitCode
res <- forall a. [Char] -> IO a -> Action a
Shake.traced ([Char]
"shell: " forall a. [a] -> [a] -> [a]
++ [Char]
cmd) forall a b. (a -> b) -> a -> b
$ [Char] -> IO ExitCode
Process.system [Char]
cmd
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
res forall a. Eq a => a -> a -> Bool
/= ExitCode
Exit.ExitSuccess) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => [Char] -> m a
errorIO forall a b. (a -> b) -> a -> b
$ [Char]
"Failed:\n" forall a. [a] -> [a] -> [a]
++ [Char]
cmd

-- | Recursively find files below a directory.
findFiles :: (FilePath -> Bool) -> Shake.FilePattern -> FilePath
    -> Shake.Action [FilePath]
findFiles :: ([Char] -> Bool) -> [Char] -> [Char] -> Action [[Char]]
findFiles [Char] -> Bool
acceptDir [Char]
filePattern [Char]
dir = do
    [[Char]]
fns <- forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
System.FilePath.normalise forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
dir </>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [Char] -> [[Char]] -> Action [[Char]]
Shake.getDirectoryFiles [Char]
dir [[Char]
filePattern]
    [[Char]]
dirs <- forall a b. (a -> b) -> [a] -> [b]
map ([Char]
dir </>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
acceptDir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Action [[Char]]
Shake.getDirectoryDirs [Char]
dir
    [[[Char]]]
rest <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([Char] -> Bool) -> [Char] -> [Char] -> Action [[Char]]
findFiles [Char] -> Bool
acceptDir [Char]
filePattern) [[Char]]
dirs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]]
fnsforall a. a -> [a] -> [a]
:[[[Char]]]
rest)

findHs :: Shake.FilePattern -> FilePath -> Shake.Action [FilePath]
findHs :: [Char] -> [Char] -> Action [[Char]]
findHs = ([Char] -> Bool) -> [Char] -> [Char] -> Action [[Char]]
findFiles forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
Char.isUpper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
1

-- | Run an Action, useful for interactive testing.
runIO :: FilePath -> Shake.Action a -> IO a
runIO :: forall a. [Char] -> Action a -> IO a
runIO [Char]
shakeDir Action a
action = do
    MVar a
mvar <- forall a. IO (MVar a)
MVar.newEmptyMVar
    ShakeOptions -> Rules () -> IO ()
Shake.shake ShakeOptions
options forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Action a -> Rules ()
Shake.action forall a b. (a -> b) -> a -> b
$ do
        a
result <- Action a
action
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mvar a
result
    forall a. MVar a -> IO a
MVar.takeMVar MVar a
mvar
    where
    options :: ShakeOptions
options = ShakeOptions
Shake.shakeOptions { shakeFiles :: [Char]
Shake.shakeFiles = [Char]
shakeDir }

-- * platform

data Platform = Mac | Linux deriving (Platform -> Platform -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Platform -> Platform -> Bool
$c/= :: Platform -> Platform -> Bool
== :: Platform -> Platform -> Bool
$c== :: Platform -> Platform -> Bool
Eq, Int -> Platform -> [Char] -> [Char]
[Platform] -> [Char] -> [Char]
Platform -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Platform] -> [Char] -> [Char]
$cshowList :: [Platform] -> [Char] -> [Char]
show :: Platform -> [Char]
$cshow :: Platform -> [Char]
showsPrec :: Int -> Platform -> [Char] -> [Char]
$cshowsPrec :: Int -> Platform -> [Char] -> [Char]
Show)

platform :: Platform
platform :: Platform
platform = case [Char]
System.Info.os of
    [Char]
"darwin" -> Platform
Mac
    [Char]
"linux" -> Platform
Linux
    [Char]
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"unknown platform: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
System.Info.os

-- * ghc

-- | An exact package id suitable for the -package-id flag.
newtype PackageId = PackageId String
    deriving (PackageId -> PackageId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageId -> PackageId -> Bool
$c/= :: PackageId -> PackageId -> Bool
== :: PackageId -> PackageId -> Bool
$c== :: PackageId -> PackageId -> Bool
Eq, Int -> PackageId -> [Char] -> [Char]
[PackageId] -> [Char] -> [Char]
PackageId -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [PackageId] -> [Char] -> [Char]
$cshowList :: [PackageId] -> [Char] -> [Char]
show :: PackageId -> [Char]
$cshow :: PackageId -> [Char]
showsPrec :: Int -> PackageId -> [Char] -> [Char]
$cshowsPrec :: Int -> PackageId -> [Char] -> [Char]
Show)

readGhcEnvironment :: IO (Maybe ([FilePath], [PackageId]))
readGhcEnvironment :: IO (Maybe ([[Char]], [PackageId]))
readGhcEnvironment = do
    [[Char]]
fns <- [Char] -> IO [[Char]]
Directory.listDirectory [Char]
"."
    case forall a. (a -> Bool) -> [a] -> [a]
filter ([Char]
".ghc.environment." `List.isPrefixOf`) [[Char]]
fns of
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        [[Char]
fn] -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe Text -> Maybe (Either [Char] PackageId)
parseGhcEnvironment forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                [Char] -> IO Text
Text.IO.readFile [Char]
fn
        [[Char]]
fns -> forall (m :: * -> *) a. MonadIO m => [Char] -> m a
errorIO forall a b. (a -> b) -> a -> b
$ [Char]
"multiple .ghc.environment.* files: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [[Char]]
fns

parseGhcEnvironment :: Text -> Maybe (Either FilePath PackageId)
parseGhcEnvironment :: Text -> Maybe (Either [Char] PackageId)
parseGhcEnvironment Text
line = case Text -> [Text]
Text.words Text
line of
    [Text
"package-db", Text
path] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack Text
path
    [Text
"package-id", Text
pkg] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> PackageId
PackageId forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack Text
pkg
    [Text]
_ -> forall a. Maybe a
Nothing

-- * general

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
cond m a
consequent m a
alternative =
    m Bool
cond forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then m a
consequent else m a
alternative

whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
cond m ()
consequent = m Bool
cond forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b m ()
consequent

errorIO :: Trans.MonadIO m => String -> m a
errorIO :: forall (m :: * -> *) a. MonadIO m => [Char] -> m a
errorIO = forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
Exception.throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ErrorCall
Exception.ErrorCall