{-# LANGUAGE NoImplicitPrelude         #-}
{-# LANGUAGE OverloadedStrings         #-}

module Stack.Prelude
  ( withSystemTempDir
  , withKeepSystemTempDir
  , sinkProcessStderrStdout
  , sinkProcessStdout
  , logProcessStderrStdout
  , readProcessNull
  , withProcessContext
  , stripCR
  , prompt
  , promptPassword
  , promptBool
  , FirstTrue (..)
  , fromFirstTrue
  , defaultFirstTrue
  , FirstFalse (..)
  , fromFirstFalse
  , defaultFirstFalse
  , writeBinaryFileAtomic
  , bugReport
  , bugPrettyReport
  , blankLine
  , putUtf8Builder
  , putBuilder
  , ppException
  , prettyThrowIO
  , prettyThrowM
  , mcons
  , MungedPackageId (..)
  , MungedPackageName (..)
  , LibraryName (..)
  , module X
  -- * Re-exports from the rio-pretty print package

  , HasStylesUpdate (..)
  , HasTerm (..)
  , Pretty (..)
  , PrettyException (..)
  , PrettyRawSnapshotLocation (..)
  , StyleDoc
  , Style (..)
  , StyleSpec
  , StylesUpdate (..)
  , (<+>)
  , align
  , bulletedList
  , debugBracket
  , defaultStyles
  , displayWithColor
  , encloseSep
  , fill
  , fillSep
  , flow
  , hang
  , hcat
  , hsep
  , indent
  , line
  , logLevelToStyle
  , mkNarrativeList
  , parens
  , parseStylesUpdateFromString
  , prettyDebug
  , prettyDebugL
  , prettyError
  , prettyErrorL
  , prettyGeneric
  , prettyInfo
  , prettyInfoL
  , prettyInfoS
  , prettyNote
  , prettyNoteL
  , prettyNoteS
  , prettyWarn
  , prettyWarnL
  , prettyWarnNoIndent
  , prettyWarnS
  , punctuate
  , sep
  , softbreak
  , softline
  , spacedBulletedList
  , string
  , style
  , vsep
  ) where

import           Data.Monoid as X
                   ( Any (..), Endo (..), First (..), Sum (..) )
import           Data.Conduit as X ( ConduitM, runConduit, (.|) )
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import           Data.Conduit.Process.Typed
                   ( byteStringInput, createSource, withLoggedProcess_ )
import qualified Data.Text.IO as T
import           Distribution.Types.LibraryName ( LibraryName (..) )
import           Distribution.Types.MungedPackageId ( MungedPackageId (..) )
import           Distribution.Types.MungedPackageName ( MungedPackageName (..) )
import           Pantry as X hiding ( Package (..), loadSnapshot )
import           Path as X
                   ( Abs, Dir, File, Path, Rel, toFilePath )
import qualified Path.IO
import           RIO as X
import           RIO.File as X hiding ( writeBinaryFileAtomic )
import           RIO.PrettyPrint
                   ( HasStylesUpdate (..), HasTerm (..), Pretty (..), Style (..)
                   , StyleDoc, (<+>), align, blankLine, bulletedList
                   , debugBracket, displayWithColor, encloseSep, fill, fillSep
                   , flow, hang, hcat, hsep, indent, line, logLevelToStyle
                   , mkNarrativeList, parens, prettyDebug, prettyDebugL
                   , prettyError, prettyErrorL, prettyGeneric, prettyInfo
                   , prettyInfoL, prettyInfoS, prettyNote, prettyNoteL
                   , prettyNoteS, prettyWarn, prettyWarnL, prettyWarnNoIndent
                   , prettyWarnS, punctuate, sep, softbreak, softline
                   , spacedBulletedList, string, style, stylesUpdateL, useColorL
                   , vsep
                   )
import           RIO.PrettyPrint.DefaultStyles (defaultStyles)
import           RIO.PrettyPrint.PrettyException
                   ( PrettyException (..), ppException, prettyThrowIO
                   , prettyThrowM
                   )
import           RIO.PrettyPrint.StylesUpdate
                   ( StylesUpdate (..), parseStylesUpdateFromString )
import           RIO.PrettyPrint.Types ( StyleSpec )
import           RIO.Process
                   ( HasProcessContext (..), ProcessConfig, ProcessContext
                   , closed, getStderr, getStdout, proc, readProcess_, setStderr
                   , setStdin, setStdout, waitExitCode, withProcessWait_
                   , workingDirL
                   )
import qualified RIO.Text as T
import           System.IO.Echo ( withoutInputEcho )

-- | Path version

withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
withSystemTempDir :: forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> (Path Abs Dir -> m a) -> m a
withSystemTempDir [Char]
str Path Abs Dir -> m a
inner = ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
  [Char] -> (Path Abs Dir -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> (Path Abs Dir -> m a) -> m a
Path.IO.withSystemTempDir [Char]
str ((Path Abs Dir -> IO a) -> IO a) -> (Path Abs Dir -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> (Path Abs Dir -> m a) -> Path Abs Dir -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> m a
inner

-- | Like `withSystemTempDir`, but the temporary directory is not deleted.

withKeepSystemTempDir :: MonadUnliftIO m
                      => String
                      -> (Path Abs Dir -> m a)
                      -> m a
withKeepSystemTempDir :: forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> (Path Abs Dir -> m a) -> m a
withKeepSystemTempDir [Char]
str Path Abs Dir -> m a
inner = ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> do
  Path Abs Dir
path <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
Path.IO.getTempDir
  Path Abs Dir
dir <- Path Abs Dir -> [Char] -> IO (Path Abs Dir)
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> [Char] -> m (Path Abs Dir)
Path.IO.createTempDir Path Abs Dir
path [Char]
str
  m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> m a -> IO a
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> m a
inner Path Abs Dir
dir

-- | Consume the stdout and stderr of a process feeding strict 'ByteString's to

-- the consumers.

--

-- Throws a 'ReadProcessException' if unsuccessful in launching, or

-- 'ExitCodeException' if the process itself fails.

sinkProcessStderrStdout ::
     forall e o env. (HasProcessContext env, HasLogFunc env, HasCallStack)
  => String -- ^ Command

  -> [String] -- ^ Command line arguments

  -> ConduitM ByteString Void (RIO env) e -- ^ Sink for stderr

  -> ConduitM ByteString Void (RIO env) o -- ^ Sink for stdout

  -> RIO env (e,o)
sinkProcessStderrStdout :: forall e o env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
[Char]
-> [[Char]]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout [Char]
name [[Char]]
args ConduitM ByteString Void (RIO env) e
sinkStderr ConduitM ByteString Void (RIO env) o
sinkStdout =
  [Char]
-> [[Char]]
-> (ProcessConfig () () () -> RIO env (e, o))
-> RIO env (e, o)
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
name [[Char]]
args ((ProcessConfig () () () -> RIO env (e, o)) -> RIO env (e, o))
-> (ProcessConfig () () () -> RIO env (e, o)) -> RIO env (e, o)
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc0 -> do
    let pc :: ProcessConfig
  ()
  (ConduitM i ByteString (RIO env) ())
  (ConduitM i ByteString (RIO env) ())
pc = StreamSpec 'STOutput (ConduitM i ByteString (RIO env) ())
-> ProcessConfig () () (ConduitM i ByteString (RIO env) ())
-> ProcessConfig
     ()
     (ConduitM i ByteString (RIO env) ())
     (ConduitM i ByteString (RIO env) ())
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput (ConduitM i ByteString (RIO env) ())
forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource
           (ProcessConfig () () (ConduitM i ByteString (RIO env) ())
 -> ProcessConfig
      ()
      (ConduitM i ByteString (RIO env) ())
      (ConduitM i ByteString (RIO env) ()))
-> ProcessConfig () () (ConduitM i ByteString (RIO env) ())
-> ProcessConfig
     ()
     (ConduitM i ByteString (RIO env) ())
     (ConduitM i ByteString (RIO env) ())
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput (ConduitM i ByteString (RIO env) ())
-> ProcessConfig () () ()
-> ProcessConfig () () (ConduitM i ByteString (RIO env) ())
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput (ConduitM i ByteString (RIO env) ())
forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource
           -- Don't use closed, since that can break ./configure scripts

           -- See https://github.com/commercialhaskell/stack/pull/4722

           (ProcessConfig () () ()
 -> ProcessConfig () () (ConduitM i ByteString (RIO env) ()))
-> ProcessConfig () () ()
-> ProcessConfig () () (ConduitM i ByteString (RIO env) ())
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STInput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin (ByteString -> StreamSpec 'STInput ()
byteStringInput ByteString
"")
             ProcessConfig () () ()
pc0
    ProcessConfig
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
-> (Process
      ()
      (ConduitM () ByteString (RIO env) ())
      (ConduitM () ByteString (RIO env) ())
    -> RIO env (e, o))
-> RIO env (e, o)
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessWait_ ProcessConfig
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
forall {i} {i}.
ProcessConfig
  ()
  (ConduitM i ByteString (RIO env) ())
  (ConduitM i ByteString (RIO env) ())
pc ((Process
    ()
    (ConduitM () ByteString (RIO env) ())
    (ConduitM () ByteString (RIO env) ())
  -> RIO env (e, o))
 -> RIO env (e, o))
-> (Process
      ()
      (ConduitM () ByteString (RIO env) ())
      (ConduitM () ByteString (RIO env) ())
    -> RIO env (e, o))
-> RIO env (e, o)
forall a b. (a -> b) -> a -> b
$ \Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p ->
      (ConduitT () Void (RIO env) e -> RIO env e
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
-> ConduitM () ByteString (RIO env) ()
forall stdin stdout stderr. Process stdin stdout stderr -> stderr
getStderr Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p ConduitM () ByteString (RIO env) ()
-> ConduitM ByteString Void (RIO env) e
-> ConduitT () Void (RIO env) e
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM ByteString Void (RIO env) e
sinkStderr) RIO env e -> RIO env o -> RIO env (e, o)
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m (a, b)
`concurrently`
      ConduitT () Void (RIO env) o -> RIO env o
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
-> ConduitM () ByteString (RIO env) ()
forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p ConduitM () ByteString (RIO env) ()
-> ConduitM ByteString Void (RIO env) o
-> ConduitT () Void (RIO env) o
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM ByteString Void (RIO env) o
sinkStdout)) RIO env (e, o) -> RIO env ExitCode -> RIO env (e, o)
forall a b. RIO env a -> RIO env b -> RIO env a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
-> RIO env ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p

-- | Consume the stdout of a process feeding strict 'ByteString's to a consumer.

-- If the process fails, spits out stdout and stderr as error log

-- level. Should not be used for long-running processes or ones with

-- lots of output; for that use 'sinkProcessStderrStdout'.

--

-- Throws a 'ReadProcessException' if unsuccessful.

sinkProcessStdout ::
     (HasProcessContext env, HasLogFunc env, HasCallStack)
  => String -- ^ Command

  -> [String] -- ^ Command line arguments

  -> ConduitM ByteString Void (RIO env) a -- ^ Sink for stdout

  -> RIO env a
sinkProcessStdout :: forall env a.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
[Char]
-> [[Char]] -> ConduitM ByteString Void (RIO env) a -> RIO env a
sinkProcessStdout [Char]
name [[Char]]
args ConduitM ByteString Void (RIO env) a
sinkStdout =
  [Char]
-> [[Char]] -> (ProcessConfig () () () -> RIO env a) -> RIO env a
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
name [[Char]]
args ((ProcessConfig () () () -> RIO env a) -> RIO env a)
-> (ProcessConfig () () () -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc ->
  ProcessConfig () () ()
-> (Process
      ()
      (ConduitM () ByteString (RIO env) ())
      (ConduitM () ByteString (RIO env) ())
    -> RIO env a)
-> RIO env a
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored a.
MonadUnliftIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> (Process
      stdin (ConduitM () ByteString m ()) (ConduitM () ByteString m ())
    -> m a)
-> m a
withLoggedProcess_ (StreamSpec 'STInput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
closed ProcessConfig () () ()
pc) ((Process
    ()
    (ConduitM () ByteString (RIO env) ())
    (ConduitM () ByteString (RIO env) ())
  -> RIO env a)
 -> RIO env a)
-> (Process
      ()
      (ConduitM () ByteString (RIO env) ())
      (ConduitM () ByteString (RIO env) ())
    -> RIO env a)
-> RIO env a
forall a b. (a -> b) -> a -> b
$ \Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p -> Concurrently (RIO env) a -> RIO env a
forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently
    (Concurrently (RIO env) a -> RIO env a)
-> Concurrently (RIO env) a -> RIO env a
forall a b. (a -> b) -> a -> b
$ RIO env () -> Concurrently (RIO env) ()
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (ConduitT () Void (RIO env) () -> RIO env ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) () -> RIO env ())
-> ConduitT () Void (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
-> ConduitM () ByteString (RIO env) ()
forall stdin stdout stderr. Process stdin stdout stderr -> stderr
getStderr Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p ConduitM () ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) ()
-> ConduitT () Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Void (RIO env) ()
forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
CL.sinkNull)
   Concurrently (RIO env) ()
-> Concurrently (RIO env) a -> Concurrently (RIO env) a
forall a b.
Concurrently (RIO env) a
-> Concurrently (RIO env) b -> Concurrently (RIO env) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RIO env a -> Concurrently (RIO env) a
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (ConduitT () Void (RIO env) a -> RIO env a
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) a -> RIO env a)
-> ConduitT () Void (RIO env) a -> RIO env a
forall a b. (a -> b) -> a -> b
$ Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
-> ConduitM () ByteString (RIO env) ()
forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p ConduitM () ByteString (RIO env) ()
-> ConduitM ByteString Void (RIO env) a
-> ConduitT () Void (RIO env) a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM ByteString Void (RIO env) a
sinkStdout)

logProcessStderrStdout ::
     (HasCallStack, HasProcessContext env, HasLogFunc env)
  => ProcessConfig stdin stdoutIgnored stderrIgnored
  -> RIO env ()
logProcessStderrStdout :: forall env stdin stdoutIgnored stderrIgnored.
(HasCallStack, HasProcessContext env, HasLogFunc env) =>
ProcessConfig stdin stdoutIgnored stderrIgnored -> RIO env ()
logProcessStderrStdout ProcessConfig stdin stdoutIgnored stderrIgnored
pc = ProcessConfig stdin stdoutIgnored stderrIgnored
-> (Process
      stdin
      (ConduitM () ByteString (RIO env) ())
      (ConduitM () ByteString (RIO env) ())
    -> RIO env ())
-> RIO env ()
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored a.
MonadUnliftIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> (Process
      stdin (ConduitM () ByteString m ()) (ConduitM () ByteString m ())
    -> m a)
-> m a
withLoggedProcess_ ProcessConfig stdin stdoutIgnored stderrIgnored
pc ((Process
    stdin
    (ConduitM () ByteString (RIO env) ())
    (ConduitM () ByteString (RIO env) ())
  -> RIO env ())
 -> RIO env ())
-> (Process
      stdin
      (ConduitM () ByteString (RIO env) ())
      (ConduitM () ByteString (RIO env) ())
    -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Process
  stdin
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p ->
  let logLines :: ConduitT ByteString c (RIO env) ()
logLines = ConduitT ByteString ByteString (RIO env) ()
forall (m :: * -> *).
Monad m =>
ConduitT ByteString ByteString m ()
CB.lines ConduitT ByteString ByteString (RIO env) ()
-> ConduitT ByteString c (RIO env) ()
-> ConduitT ByteString c (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (ByteString -> RIO env ()) -> ConduitT ByteString c (RIO env) ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ())
-> (ByteString -> Utf8Builder) -> ByteString -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Utf8Builder
displayBytesUtf8)
  in  Concurrently (RIO env) () -> RIO env ()
forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently
        (Concurrently (RIO env) () -> RIO env ())
-> Concurrently (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$  RIO env () -> Concurrently (RIO env) ()
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (ConduitT () Void (RIO env) () -> RIO env ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) () -> RIO env ())
-> ConduitT () Void (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Process
  stdin
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
-> ConduitM () ByteString (RIO env) ()
forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process
  stdin
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p ConduitM () ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) ()
-> ConduitT () Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Void (RIO env) ()
forall {c}. ConduitT ByteString c (RIO env) ()
logLines)
        Concurrently (RIO env) ()
-> Concurrently (RIO env) () -> Concurrently (RIO env) ()
forall a b.
Concurrently (RIO env) a
-> Concurrently (RIO env) b -> Concurrently (RIO env) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RIO env () -> Concurrently (RIO env) ()
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (ConduitT () Void (RIO env) () -> RIO env ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) () -> RIO env ())
-> ConduitT () Void (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Process
  stdin
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
-> ConduitM () ByteString (RIO env) ()
forall stdin stdout stderr. Process stdin stdout stderr -> stderr
getStderr Process
  stdin
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p ConduitM () ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) ()
-> ConduitT () Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Void (RIO env) ()
forall {c}. ConduitT ByteString c (RIO env) ()
logLines)

-- | Read from the process, ignoring any output.

--

-- Throws a 'ReadProcessException' exception if the process fails.

readProcessNull :: (HasProcessContext env, HasLogFunc env, HasCallStack)
                => String -- ^ Command

                -> [String] -- ^ Command line arguments

                -> RIO env ()
readProcessNull :: forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
[Char] -> [[Char]] -> RIO env ()
readProcessNull [Char]
name [[Char]]
args =
  -- We want the output to appear in any exceptions, so we capture and drop it

  RIO env (ByteString, ByteString) -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env (ByteString, ByteString) -> RIO env ())
-> RIO env (ByteString, ByteString) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char]
-> [[Char]]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
name [[Char]]
args ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_

-- | Use the new 'ProcessContext', but retain the working directory

-- from the parent environment.

withProcessContext :: HasProcessContext env
                   => ProcessContext
                   -> RIO env a
                   -> RIO env a
withProcessContext :: forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
pcNew RIO env a
inner = do
  ProcessContext
pcOld <- Getting ProcessContext env ProcessContext -> RIO env ProcessContext
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProcessContext env ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
processContextL
  let pcNew' :: ProcessContext
pcNew' = ASetter ProcessContext ProcessContext (Maybe [Char]) (Maybe [Char])
-> Maybe [Char] -> ProcessContext -> ProcessContext
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ProcessContext ProcessContext (Maybe [Char]) (Maybe [Char])
forall env. HasProcessContext env => Lens' env (Maybe [Char])
Lens' ProcessContext (Maybe [Char])
workingDirL (Getting (Maybe [Char]) ProcessContext (Maybe [Char])
-> ProcessContext -> Maybe [Char]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe [Char]) ProcessContext (Maybe [Char])
forall env. HasProcessContext env => Lens' env (Maybe [Char])
Lens' ProcessContext (Maybe [Char])
workingDirL ProcessContext
pcOld) ProcessContext
pcNew
  (env -> env) -> RIO env a -> RIO env a
forall a. (env -> env) -> RIO env a -> RIO env a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter env env ProcessContext ProcessContext
-> ProcessContext -> env -> env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter env env ProcessContext ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
processContextL ProcessContext
pcNew') RIO env a
inner

-- | Remove a trailing carriage pure if present

stripCR :: Text -> Text
stripCR :: Text -> Text
stripCR = Text -> Text -> Text
T.dropSuffix Text
"\r"

-- | Prompt the user by sending text to stdout, and taking a line of

-- input from stdin.

prompt :: MonadIO m => Text -> m Text
prompt :: forall (m :: * -> *). MonadIO m => Text -> m Text
prompt Text
txt = IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ do
  Text -> IO ()
T.putStr Text
txt
  Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
  IO Text
T.getLine

-- | Prompt the user by sending text to stdout, and collecting a line

-- of input from stdin. While taking input from stdin, input echoing is

-- disabled, to hide passwords.

--

-- Based on code from cabal-install, Distribution.Client.Upload

promptPassword :: MonadIO m => Text -> m Text
promptPassword :: forall (m :: * -> *). MonadIO m => Text -> m Text
promptPassword Text
txt = IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ do
  Text -> IO ()
T.putStr Text
txt
  Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
  -- Save/restore the terminal echoing status (no echoing for entering

  -- the password).

  Text
password <- IO Text -> IO Text
forall a. IO a -> IO a
withoutInputEcho IO Text
T.getLine
  -- Since the user's newline is not echoed, one needs to be inserted.

  Text -> IO ()
T.putStrLn Text
""
  Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
password

-- | Prompt the user by sending text to stdout, and collecting a line of

-- input from stdin. If something other than "y" or "n" is entered, then

-- print a message indicating that "y" or "n" is expected, and ask

-- again.

promptBool :: MonadIO m => Text -> m Bool
promptBool :: forall (m :: * -> *). MonadIO m => Text -> m Bool
promptBool Text
txt = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
  Text
input <- Text -> IO Text
forall (m :: * -> *). MonadIO m => Text -> m Text
prompt Text
txt
  case Text
input of
    Text
"y" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Text
"n" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Text
_ -> do
      Text -> IO ()
T.putStrLn Text
"Please press either 'y' or 'n', and then enter."
      Text -> IO Bool
forall (m :: * -> *). MonadIO m => Text -> m Bool
promptBool Text
txt

-- | Like @First Bool@, but the default is @True@.

newtype FirstTrue
  = FirstTrue { FirstTrue -> Maybe Bool
getFirstTrue :: Maybe Bool }
  deriving (FirstTrue -> FirstTrue -> Bool
(FirstTrue -> FirstTrue -> Bool)
-> (FirstTrue -> FirstTrue -> Bool) -> Eq FirstTrue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FirstTrue -> FirstTrue -> Bool
== :: FirstTrue -> FirstTrue -> Bool
$c/= :: FirstTrue -> FirstTrue -> Bool
/= :: FirstTrue -> FirstTrue -> Bool
Eq, Eq FirstTrue
Eq FirstTrue
-> (FirstTrue -> FirstTrue -> Ordering)
-> (FirstTrue -> FirstTrue -> Bool)
-> (FirstTrue -> FirstTrue -> Bool)
-> (FirstTrue -> FirstTrue -> Bool)
-> (FirstTrue -> FirstTrue -> Bool)
-> (FirstTrue -> FirstTrue -> FirstTrue)
-> (FirstTrue -> FirstTrue -> FirstTrue)
-> Ord FirstTrue
FirstTrue -> FirstTrue -> Bool
FirstTrue -> FirstTrue -> Ordering
FirstTrue -> FirstTrue -> FirstTrue
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FirstTrue -> FirstTrue -> Ordering
compare :: FirstTrue -> FirstTrue -> Ordering
$c< :: FirstTrue -> FirstTrue -> Bool
< :: FirstTrue -> FirstTrue -> Bool
$c<= :: FirstTrue -> FirstTrue -> Bool
<= :: FirstTrue -> FirstTrue -> Bool
$c> :: FirstTrue -> FirstTrue -> Bool
> :: FirstTrue -> FirstTrue -> Bool
$c>= :: FirstTrue -> FirstTrue -> Bool
>= :: FirstTrue -> FirstTrue -> Bool
$cmax :: FirstTrue -> FirstTrue -> FirstTrue
max :: FirstTrue -> FirstTrue -> FirstTrue
$cmin :: FirstTrue -> FirstTrue -> FirstTrue
min :: FirstTrue -> FirstTrue -> FirstTrue
Ord, Int -> FirstTrue -> ShowS
[FirstTrue] -> ShowS
FirstTrue -> [Char]
(Int -> FirstTrue -> ShowS)
-> (FirstTrue -> [Char])
-> ([FirstTrue] -> ShowS)
-> Show FirstTrue
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FirstTrue -> ShowS
showsPrec :: Int -> FirstTrue -> ShowS
$cshow :: FirstTrue -> [Char]
show :: FirstTrue -> [Char]
$cshowList :: [FirstTrue] -> ShowS
showList :: [FirstTrue] -> ShowS
Show)

instance Semigroup FirstTrue where
  FirstTrue (Just Bool
x) <> :: FirstTrue -> FirstTrue -> FirstTrue
<> FirstTrue
_ = Maybe Bool -> FirstTrue
FirstTrue (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x)
  FirstTrue Maybe Bool
Nothing <> FirstTrue
x = FirstTrue
x

instance Monoid FirstTrue where
  mempty :: FirstTrue
mempty = Maybe Bool -> FirstTrue
FirstTrue Maybe Bool
forall a. Maybe a
Nothing
  mappend :: FirstTrue -> FirstTrue -> FirstTrue
mappend = FirstTrue -> FirstTrue -> FirstTrue
forall a. Semigroup a => a -> a -> a
(<>)

-- | Get the 'Bool', defaulting to 'True'

fromFirstTrue :: FirstTrue -> Bool
fromFirstTrue :: FirstTrue -> Bool
fromFirstTrue = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool)
-> (FirstTrue -> Maybe Bool) -> FirstTrue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FirstTrue -> Maybe Bool
getFirstTrue

-- | Helper for filling in default values

defaultFirstTrue :: (a -> FirstTrue) -> Bool
defaultFirstTrue :: forall a. (a -> FirstTrue) -> Bool
defaultFirstTrue a -> FirstTrue
_ = Bool
True

-- | Like @First Bool@, but the default is @False@.

newtype FirstFalse
  = FirstFalse { FirstFalse -> Maybe Bool
getFirstFalse :: Maybe Bool }
  deriving (FirstFalse -> FirstFalse -> Bool
(FirstFalse -> FirstFalse -> Bool)
-> (FirstFalse -> FirstFalse -> Bool) -> Eq FirstFalse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FirstFalse -> FirstFalse -> Bool
== :: FirstFalse -> FirstFalse -> Bool
$c/= :: FirstFalse -> FirstFalse -> Bool
/= :: FirstFalse -> FirstFalse -> Bool
Eq, Eq FirstFalse
Eq FirstFalse
-> (FirstFalse -> FirstFalse -> Ordering)
-> (FirstFalse -> FirstFalse -> Bool)
-> (FirstFalse -> FirstFalse -> Bool)
-> (FirstFalse -> FirstFalse -> Bool)
-> (FirstFalse -> FirstFalse -> Bool)
-> (FirstFalse -> FirstFalse -> FirstFalse)
-> (FirstFalse -> FirstFalse -> FirstFalse)
-> Ord FirstFalse
FirstFalse -> FirstFalse -> Bool
FirstFalse -> FirstFalse -> Ordering
FirstFalse -> FirstFalse -> FirstFalse
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FirstFalse -> FirstFalse -> Ordering
compare :: FirstFalse -> FirstFalse -> Ordering
$c< :: FirstFalse -> FirstFalse -> Bool
< :: FirstFalse -> FirstFalse -> Bool
$c<= :: FirstFalse -> FirstFalse -> Bool
<= :: FirstFalse -> FirstFalse -> Bool
$c> :: FirstFalse -> FirstFalse -> Bool
> :: FirstFalse -> FirstFalse -> Bool
$c>= :: FirstFalse -> FirstFalse -> Bool
>= :: FirstFalse -> FirstFalse -> Bool
$cmax :: FirstFalse -> FirstFalse -> FirstFalse
max :: FirstFalse -> FirstFalse -> FirstFalse
$cmin :: FirstFalse -> FirstFalse -> FirstFalse
min :: FirstFalse -> FirstFalse -> FirstFalse
Ord, Int -> FirstFalse -> ShowS
[FirstFalse] -> ShowS
FirstFalse -> [Char]
(Int -> FirstFalse -> ShowS)
-> (FirstFalse -> [Char])
-> ([FirstFalse] -> ShowS)
-> Show FirstFalse
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FirstFalse -> ShowS
showsPrec :: Int -> FirstFalse -> ShowS
$cshow :: FirstFalse -> [Char]
show :: FirstFalse -> [Char]
$cshowList :: [FirstFalse] -> ShowS
showList :: [FirstFalse] -> ShowS
Show)

instance Semigroup FirstFalse where
  FirstFalse (Just Bool
x) <> :: FirstFalse -> FirstFalse -> FirstFalse
<> FirstFalse
_ = Maybe Bool -> FirstFalse
FirstFalse (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x)
  FirstFalse Maybe Bool
Nothing <> FirstFalse
x = FirstFalse
x

instance Monoid FirstFalse where
  mempty :: FirstFalse
mempty = Maybe Bool -> FirstFalse
FirstFalse Maybe Bool
forall a. Maybe a
Nothing
  mappend :: FirstFalse -> FirstFalse -> FirstFalse
mappend = FirstFalse -> FirstFalse -> FirstFalse
forall a. Semigroup a => a -> a -> a
(<>)

-- | Get the 'Bool', defaulting to 'False'

fromFirstFalse :: FirstFalse -> Bool
fromFirstFalse :: FirstFalse -> Bool
fromFirstFalse = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool)
-> (FirstFalse -> Maybe Bool) -> FirstFalse -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FirstFalse -> Maybe Bool
getFirstFalse

-- | Helper for filling in default values

defaultFirstFalse :: (a -> FirstFalse) -> Bool
defaultFirstFalse :: forall a. (a -> FirstFalse) -> Bool
defaultFirstFalse a -> FirstFalse
_ = Bool
False

-- | Write a @Builder@ to a file and atomically rename.

writeBinaryFileAtomic :: MonadIO m => Path absrel File -> Builder -> m ()
writeBinaryFileAtomic :: forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path absrel File
fp Builder
builder =
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
  [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m r) -> m r
withBinaryFileAtomic (Path absrel File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path absrel File
fp) IOMode
WriteMode (Handle -> Builder -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Builder -> m ()
`hPutBuilder` Builder
builder)

newtype PrettyRawSnapshotLocation
  = PrettyRawSnapshotLocation RawSnapshotLocation

instance Pretty PrettyRawSnapshotLocation where
  pretty :: PrettyRawSnapshotLocation -> StyleDoc
pretty (PrettyRawSnapshotLocation (RSLCompiler WantedCompiler
compiler)) =
    [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text) -> Utf8Builder -> Text
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display WantedCompiler
compiler
  pretty (PrettyRawSnapshotLocation (RSLUrl Text
url Maybe BlobKey
Nothing)) =
    Style -> StyleDoc -> StyleDoc
style Style
Url ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
url)
  pretty (PrettyRawSnapshotLocation (RSLUrl Text
url (Just BlobKey
blob))) =
    [StyleDoc] -> StyleDoc
fillSep
    [ Style -> StyleDoc -> StyleDoc
style Style
Url ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
url)
    , StyleDoc -> StyleDoc
parens (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text) -> Utf8Builder -> Text
forall a b. (a -> b) -> a -> b
$ BlobKey -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display BlobKey
blob
    ]
  pretty (PrettyRawSnapshotLocation (RSLFilePath ResolvedPath File
resolved)) =
    Style -> StyleDoc -> StyleDoc
style Style
File ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ RelFilePath -> [Char]
forall a. Show a => a -> [Char]
show (RelFilePath -> [Char]) -> RelFilePath -> [Char]
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> RelFilePath
forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath File
resolved)
  pretty (PrettyRawSnapshotLocation (RSLSynonym SnapName
syn)) = [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ SnapName -> [Char]
forall a. Show a => a -> [Char]
show SnapName
syn

-- | Report a bug in Stack.

bugReport :: String -> String -> String
bugReport :: [Char] -> ShowS
bugReport [Char]
code [Char]
msg =
  [Char]
"Error: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
code [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
  [Char]
bugDeclaration [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
bugRequest

-- | Report a pretty bug in Stack.

bugPrettyReport :: String -> StyleDoc -> StyleDoc
bugPrettyReport :: [Char] -> StyleDoc -> StyleDoc
bugPrettyReport [Char]
code StyleDoc
msg =
     StyleDoc
"Error:" StyleDoc -> StyleDoc -> StyleDoc
<+> [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
code
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
bugDeclaration StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
msg StyleDoc -> StyleDoc -> StyleDoc
<+> [Char] -> StyleDoc
flow [Char]
bugRequest

-- | Bug declaration message.

bugDeclaration :: String
bugDeclaration :: [Char]
bugDeclaration = [Char]
"The impossible happened!"

-- | Bug report message.

bugRequest :: String
bugRequest :: [Char]
bugRequest =  [Char]
"Please report this bug at Stack's repository."

-- | Maybe cons.

mcons :: Maybe a -> [a] -> [a]
mcons :: forall a. Maybe a -> [a] -> [a]
mcons Maybe a
ma [a]
as = [a] -> (a -> [a]) -> Maybe a -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a]
as (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as) Maybe a
ma

-- | Write a 'Utf8Builder' to the standard output stream.

putUtf8Builder :: MonadIO m => Utf8Builder -> m ()
putUtf8Builder :: forall (m :: * -> *). MonadIO m => Utf8Builder -> m ()
putUtf8Builder = Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
putBuilder (Builder -> m ())
-> (Utf8Builder -> Builder) -> Utf8Builder -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Builder
getUtf8Builder

-- | Write a 'Builder' to the standard output stream.

putBuilder :: MonadIO m => Builder -> m ()
putBuilder :: forall (m :: * -> *). MonadIO m => Builder -> m ()
putBuilder = Handle -> Builder -> m ()
forall (m :: * -> *). MonadIO m => Handle -> Builder -> m ()
hPutBuilder Handle
stdout