content: {-# LANGUAGE NoImplicitPrelude   #-}
  {-# LANGUAGE NoFieldSelectors    #-}
  {-# LANGUAGE OverloadedRecordDot #-}
  {-# LANGUAGE OverloadedStrings   #-}
  
  {-|
  Module      : Stack.Prelude
  Description : Common types and functions.
  License     : BSD-3-Clause
  
  Common types and functions.
  -}
  
  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 (..)
    , (<+>)
    , type (~)
    , align
    , bulletedList
    , debugBracket
    , defaultStyles
    , displayWithColor
    , encloseSep
    , fill
    , fillSep
    , foldr'
    , fromPackageId
    , fromPackageName
    , 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           Data.Foldable ( Foldable(foldr') )
  import qualified Data.Text.IO as T
  import           Data.Type.Equality ( type (~) )
  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 str inner = withRunInIO $ \run ->
    Path.IO.withSystemTempDir str $ run . inner
  
  -- | Like `withSystemTempDir`, but the temporary directory is not deleted.
  withKeepSystemTempDir ::
       MonadUnliftIO m
    => String
    -> (Path Abs Dir -> m a)
    -> m a
  withKeepSystemTempDir str inner = withRunInIO $ \run -> do
    path <- Path.IO.getTempDir
    dir <- Path.IO.createTempDir path str
    run $ inner dir
  
  -- | Consume the stdout and stderr of a process feeding strict 'ByteString's to
  -- the consumers.
  --
  -- Throws a 'Rio.Process.ReadProcessException' if unsuccessful in launching, or
  -- 'Rio.Process.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 name args sinkStderr sinkStdout =
    proc name args $ \pc0 -> do
      let pc = setStdout createSource
             $ setStderr createSource
             -- Don't use closed, since that can break ./configure scripts
             -- See https://github.com/commercialhaskell/stack/pull/4722
             $ setStdin (byteStringInput "")
               pc0
      withProcessWait_ pc $ \p ->
        (runConduit (getStderr p .| sinkStderr) `concurrently`
        runConduit (getStdout p .| sinkStdout)) <* waitExitCode 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 'Rio.Process.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 name args sinkStdout =
    proc name args $ \pc ->
    withLoggedProcess_ (setStdin closed pc) $ \p -> runConcurrently
      $ Concurrently (runConduit $ getStderr p .| CL.sinkNull)
     *> Concurrently (runConduit $ getStdout p .| sinkStdout)
  
  logProcessStderrStdout ::
       (HasCallStack, HasProcessContext env, HasLogFunc env)
    => ProcessConfig stdin stdoutIgnored stderrIgnored
    -> RIO env ()
  logProcessStderrStdout pc = withLoggedProcess_ pc $ \p ->
    let logLines = CB.lines .| CL.mapM_ (logInfo . displayBytesUtf8)
    in  runConcurrently
          $  Concurrently (runConduit $ getStdout p .| logLines)
          *> Concurrently (runConduit $ getStderr p .| logLines)
  
  -- | Read from the process, ignoring any output.
  --
  -- Throws a 'Rio.Process.ReadProcessException' exception if the process fails.
  readProcessNull ::
       (HasProcessContext env, HasLogFunc env, HasCallStack)
    => String -- ^ Command
    -> [String] -- ^ Command line arguments
    -> RIO env ()
  readProcessNull name args =
    -- We want the output to appear in any exceptions, so we capture and drop it
    void $ proc name args 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 pcNew inner = do
    pcOld <- view processContextL
    let pcNew' = set workingDirL (view workingDirL pcOld) pcNew
    local (set processContextL pcNew') inner
  
  -- | Remove a trailing carriage pure if present
  stripCR :: Text -> Text
  stripCR = T.dropSuffix "\r"
  
  -- | Prompt the user by sending text to stdout, and taking a line of
  -- input from stdin.
  prompt :: MonadIO m => Text -> m Text
  prompt txt = liftIO $ do
    T.putStr txt
    hFlush stdout
    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 txt = liftIO $ do
    T.putStr txt
    hFlush stdout
    -- Save/restore the terminal echoing status (no echoing for entering
    -- the password).
    password <- withoutInputEcho T.getLine
    -- Since the user's newline is not echoed, one needs to be inserted.
    T.putStrLn ""
    pure 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 txt = liftIO $
    prompt txt >>= \case
      "y" -> pure True
      "n" -> pure False
      _ -> do
        T.putStrLn "Please press either 'y' or 'n', and then enter."
        promptBool txt
  
  -- | Like @First Bool@, but the default is @True@.
  newtype FirstTrue
    = FirstTrue { firstTrue :: Maybe Bool }
    deriving (Eq, Ord, Show)
  
  instance Semigroup FirstTrue where
    FirstTrue (Just x) <> _ = FirstTrue (Just x)
    FirstTrue Nothing <> x = x
  
  instance Monoid FirstTrue where
    mempty = FirstTrue Nothing
    mappend = (<>)
  
  -- | Get the 'Bool', defaulting to 'True'
  fromFirstTrue :: FirstTrue -> Bool
  fromFirstTrue = fromMaybe True . (.firstTrue)
  
  -- | Helper for filling in default values
  defaultFirstTrue :: FirstTrue -> Bool
  defaultFirstTrue _ = True
  
  -- | Like @First Bool@, but the default is @False@.
  newtype FirstFalse
    = FirstFalse { firstFalse :: Maybe Bool }
    deriving (Eq, Ord, Show)
  
  instance Semigroup FirstFalse where
    FirstFalse (Just x) <> _ = FirstFalse (Just x)
    FirstFalse Nothing <> x = x
  
  instance Monoid FirstFalse where
    mempty = FirstFalse Nothing
    mappend = (<>)
  
  -- | Get the 'Bool', defaulting to 'False'
  fromFirstFalse :: FirstFalse -> Bool
  fromFirstFalse = fromMaybe False . (.firstFalse)
  
  -- | Helper for filling in default values
  defaultFirstFalse :: FirstFalse -> Bool
  defaultFirstFalse _ = False
  
  -- | Write a @Builder@ to a file and atomically rename.
  writeBinaryFileAtomic :: MonadIO m => Path absrel File -> Builder -> m ()
  writeBinaryFileAtomic fp builder =
    liftIO $
    withBinaryFileAtomic (toFilePath fp) WriteMode (`hPutBuilder` builder)
  
  newtype PrettyRawSnapshotLocation
    = PrettyRawSnapshotLocation RawSnapshotLocation
  
  instance Pretty PrettyRawSnapshotLocation where
    pretty (PrettyRawSnapshotLocation (RSLCompiler compiler)) =
      fromString $ T.unpack $ utf8BuilderToText $ display compiler
    pretty (PrettyRawSnapshotLocation (RSLUrl url Nothing)) =
      style Url (fromString $ T.unpack url)
    pretty (PrettyRawSnapshotLocation (RSLUrl url (Just blob))) =
      fillSep
      [ style Url (fromString $ T.unpack url)
      , parens $ fromString $ T.unpack $ utf8BuilderToText $ display blob
      ]
    pretty (PrettyRawSnapshotLocation (RSLFilePath resolved)) =
      style File (fromString $ show $ resolvedRelative resolved)
    pretty (PrettyRawSnapshotLocation (RSLSynonym syn)) = fromString $ show syn
  
  -- | Report a bug in Stack.
  bugReport :: String -> String -> String
  bugReport code msg =
    "Error: " ++ code ++ "\n" ++
    bugDeclaration ++ " " ++ msg ++ " " ++ bugRequest
  
  -- | Report a pretty bug in Stack.
  bugPrettyReport :: String -> StyleDoc -> StyleDoc
  bugPrettyReport code msg =
       "Error:" <+> fromString code
    <> line
    <> flow bugDeclaration <+> msg <+> flow bugRequest
  
  -- | Bug declaration message.
  bugDeclaration :: String
  bugDeclaration = "The impossible happened!"
  
  -- | Bug report message.
  bugRequest :: String
  bugRequest =  "Please report this bug at Stack's repository."
  
  -- | Maybe cons.
  mcons :: Maybe a -> [a] -> [a]
  mcons ma as = maybe as (:as) ma
  
  -- | Write a t'Utf8Builder' to the standard output stream.
  putUtf8Builder :: MonadIO m => Utf8Builder -> m ()
  putUtf8Builder = putBuilder . getUtf8Builder
  
  -- | Write a 'Builder' to the standard output stream.
  putBuilder :: MonadIO m => Builder -> m ()
  putBuilder = hPutBuilder stdout
  
  -- | Convert a package identifier to a value of a string-like type.
  fromPackageId :: IsString a => PackageIdentifier -> a
  fromPackageId = fromString . packageIdentifierString
  
  -- | Convert a package name to a value of a string-like type.
  fromPackageName :: IsString a => PackageName -> a
  fromPackageName = fromString . packageNameString
  