module Unison.Codebase.Editor.HandleInput.HistoryComment (handleHistoryComment) where

import Control.Monad.Reader
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Data.Time.Clock.POSIX qualified as Time
import Text.RawString.QQ (r)
import U.Codebase.Config qualified as Config
import U.Codebase.HashTags
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Auth.CredentialManager qualified as CredMan
import Unison.Auth.PersonalKey qualified as PK
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.Input (BranchId2)
import Unison.Codebase.Editor.Output (Output (..))
import Unison.Codebase.Path qualified as Path
import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..))
import Unison.Core.Project (ProjectAndBranch (..))
import Unison.Hash qualified as Hash
import Unison.Hashing.V2
  ( hashHistoryComment,
    hashHistoryCommentRevision,
  )
import Unison.HistoryComment (HistoryComment (..), HistoryCommentRevision (..))
import Unison.Prelude
import UnliftIO qualified
import UnliftIO.Directory (findExecutable)
import UnliftIO.Environment qualified as Env
import UnliftIO.Process qualified as Proc

handleHistoryComment :: Maybe BranchId2 -> Maybe Text -> Cli ()
handleHistoryComment :: Maybe BranchId2 -> Maybe Text -> Cli ()
handleHistoryComment Maybe BranchId2
mayThingToAnnotate Maybe Text
mayMessage = do
  Cli.Env {CredentialManager
credentialManager :: CredentialManager
$sel:credentialManager:Env :: Env -> CredentialManager
credentialManager} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  PersonalPrivateKey
personalKey <- IO PersonalPrivateKey -> Cli PersonalPrivateKey
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CredentialManager -> IO PersonalPrivateKey
forall (m :: * -> *).
MonadUnliftIO m =>
CredentialManager -> m PersonalPrivateKey
CredMan.getOrCreatePersonalKey CredentialManager
credentialManager)
  let authorThumbprint :: KeyThumbprint
authorThumbprint = PersonalPrivateKey -> KeyThumbprint
PK.personalKeyThumbprint PersonalPrivateKey
personalKey
  Maybe AuthorName
mayAuthorName <-
    Transaction (Maybe AuthorName) -> Cli (Maybe AuthorName)
forall a. Transaction a -> Cli a
Cli.runTransaction do
      Maybe AuthorName
authorName <- Transaction (Maybe AuthorName)
Q.getAuthorName
      Maybe AuthorName -> Transaction (Maybe AuthorName)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe AuthorName
authorName)
  AuthorName
authorName <- case Maybe AuthorName
mayAuthorName of
    Maybe AuthorName
Nothing -> Output -> Cli AuthorName
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli AuthorName) -> Output -> Cli AuthorName
forall a b. (a -> b) -> a -> b
$ Output
AuthorNameRequired
    Just AuthorName
authorName -> AuthorName -> Cli AuthorName
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthorName
authorName
  CausalHash
causalHash <- case Maybe BranchId2
mayThingToAnnotate of
    Maybe BranchId2
Nothing -> do
      Branch IO -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash (Branch IO -> CausalHash) -> Cli (Branch IO) -> Cli CausalHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cli (Branch IO)
Cli.getCurrentProjectRoot
    Just (Left ShortCausalHash
sch) -> do
      ((forall void. Output -> Transaction void)
 -> Transaction CausalHash)
-> Cli CausalHash
forall a.
((forall void. Output -> Transaction void) -> Transaction a)
-> Cli a
Cli.runTransactionWithRollback \forall void. Output -> Transaction void
rollback -> (forall void. Output -> Transaction void)
-> ShortCausalHash -> Transaction CausalHash
Cli.resolveShortCausalHashToCausalHash Output -> Transaction void
forall void. Output -> Transaction void
rollback ShortCausalHash
sch
    Just (Right BranchRelativePath
brp) -> case BranchRelativePath
brp of
      BranchPathInCurrentProject ProjectBranchName
projectBranchName Absolute
path
        | Absolute
path Absolute -> Absolute -> Bool
forall a. Eq a => a -> a -> Bool
== Absolute
Path.Root -> do
            ProjectAndBranch Project ProjectBranch
pab <- ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
-> Cli (ProjectAndBranch Project ProjectBranch)
ProjectUtils.resolveProjectBranch (Maybe ProjectName
-> Maybe ProjectBranchName
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch Maybe ProjectName
forall a. Maybe a
Nothing (ProjectBranchName -> Maybe ProjectBranchName
forall a. a -> Maybe a
Just ProjectBranchName
projectBranchName))
            Transaction CausalHash -> Cli CausalHash
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction CausalHash -> Cli CausalHash)
-> Transaction CausalHash -> Cli CausalHash
forall a b. (a -> b) -> a -> b
$ ProjectBranch -> Transaction CausalHash
ProjectUtils.getProjectBranchCausalHash ProjectAndBranch Project ProjectBranch
pab.branch
        | Bool
otherwise -> Output -> Cli CausalHash
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli CausalHash) -> Output -> Cli CausalHash
forall a b. (a -> b) -> a -> b
$ Text -> Output
InvalidCommentTarget Text
"commenting on paths is currently unsupported."
      QualifiedBranchPath ProjectName
projectName ProjectBranchName
projectBranchName Absolute
path
        | Absolute
path Absolute -> Absolute -> Bool
forall a. Eq a => a -> a -> Bool
== Absolute
Path.Root -> do
            ProjectAndBranch Project ProjectBranch
pab <- ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
-> Cli (ProjectAndBranch Project ProjectBranch)
ProjectUtils.resolveProjectBranch (Maybe ProjectName
-> Maybe ProjectBranchName
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (ProjectName -> Maybe ProjectName
forall a. a -> Maybe a
Just ProjectName
projectName) (ProjectBranchName -> Maybe ProjectBranchName
forall a. a -> Maybe a
Just ProjectBranchName
projectBranchName))
            Transaction CausalHash -> Cli CausalHash
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction CausalHash -> Cli CausalHash)
-> Transaction CausalHash -> Cli CausalHash
forall a b. (a -> b) -> a -> b
$ ProjectBranch -> Transaction CausalHash
ProjectUtils.getProjectBranchCausalHash ProjectAndBranch Project ProjectBranch
pab.branch
        | Bool
otherwise -> Output -> Cli CausalHash
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli CausalHash) -> Output -> Cli CausalHash
forall a b. (a -> b) -> a -> b
$ Text -> Output
InvalidCommentTarget Text
"commenting on paths is currently unsupported."
      UnqualifiedPath {} -> Output -> Cli CausalHash
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli CausalHash) -> Output -> Cli CausalHash
forall a b. (a -> b) -> a -> b
$ Text -> Output
InvalidCommentTarget Text
"commenting on paths is currently unsupported."
  (CausalHashId
causalHashId, Maybe
  (LatestHistoryComment
     KeyThumbprintId
     CausalHash
     HistoryCommentRevisionId
     HistoryCommentHash)
mayHistoryComment) <- Transaction
  (CausalHashId,
   Maybe
     (LatestHistoryComment
        KeyThumbprintId
        CausalHash
        HistoryCommentRevisionId
        HistoryCommentHash))
-> Cli
     (CausalHashId,
      Maybe
        (LatestHistoryComment
           KeyThumbprintId
           CausalHash
           HistoryCommentRevisionId
           HistoryCommentHash))
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction
   (CausalHashId,
    Maybe
      (LatestHistoryComment
         KeyThumbprintId
         CausalHash
         HistoryCommentRevisionId
         HistoryCommentHash))
 -> Cli
      (CausalHashId,
       Maybe
         (LatestHistoryComment
            KeyThumbprintId
            CausalHash
            HistoryCommentRevisionId
            HistoryCommentHash)))
-> Transaction
     (CausalHashId,
      Maybe
        (LatestHistoryComment
           KeyThumbprintId
           CausalHash
           HistoryCommentRevisionId
           HistoryCommentHash))
-> Cli
     (CausalHashId,
      Maybe
        (LatestHistoryComment
           KeyThumbprintId
           CausalHash
           HistoryCommentRevisionId
           HistoryCommentHash))
forall a b. (a -> b) -> a -> b
$ do
    CausalHashId
causalHashId <- CausalHash -> Transaction CausalHashId
Q.expectCausalHashIdByCausalHash CausalHash
causalHash
    Maybe
  (LatestHistoryComment
     KeyThumbprintId
     CausalHash
     HistoryCommentRevisionId
     HistoryCommentHash)
mayExistingCommentInfo <- CausalHashId
-> Transaction
     (Maybe
        (LatestHistoryComment
           KeyThumbprintId
           CausalHash
           HistoryCommentRevisionId
           HistoryCommentHash))
Q.getLatestCausalComment CausalHashId
causalHashId
    (CausalHashId,
 Maybe
   (LatestHistoryComment
      KeyThumbprintId
      CausalHash
      HistoryCommentRevisionId
      HistoryCommentHash))
-> Transaction
     (CausalHashId,
      Maybe
        (LatestHistoryComment
           KeyThumbprintId
           CausalHash
           HistoryCommentRevisionId
           HistoryCommentHash))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CausalHashId
causalHashId, Maybe
  (LatestHistoryComment
     KeyThumbprintId
     CausalHash
     HistoryCommentRevisionId
     HistoryCommentHash)
mayExistingCommentInfo)
  Maybe (Text, Text)
maySubjectContent <- case Maybe Text
mayMessage of
    Just Text
msg -> do
      let (Text
subject, Text
content) = Text -> (Text, Text)
cleanComment Text
msg
      Maybe (Text, Text) -> Cli (Maybe (Text, Text))
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, Text) -> Cli (Maybe (Text, Text)))
-> Maybe (Text, Text) -> Cli (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
subject, Text
content)
    Maybe Text
Nothing -> do
      let populatedMsg :: Text
populatedMsg = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
commentInstructions (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ do
            HistoryCommentRevision {Text
subject :: Text
$sel:subject:HistoryCommentRevision :: forall revisionId createdAt comment.
HistoryCommentRevision revisionId createdAt comment -> Text
subject, Text
content :: Text
$sel:content:HistoryCommentRevision :: forall revisionId createdAt comment.
HistoryCommentRevision revisionId createdAt comment -> Text
content} <- Maybe
  (LatestHistoryComment
     KeyThumbprintId
     CausalHash
     HistoryCommentRevisionId
     HistoryCommentHash)
mayHistoryComment
            Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines [Text
subject, Text
"", Text
content, Text
commentInstructions]
      Maybe (Text, Text)
mayNewMessage <- IO (Maybe (Text, Text)) -> Cli (Maybe (Text, Text))
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe Text -> IO (Maybe (Text, Text))
forall (m :: * -> *).
MonadUnliftIO m =>
Maybe Text -> m (Maybe (Text, Text))
editMessage (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
populatedMsg))
      case Maybe (Text, Text)
mayNewMessage of
        Maybe (Text, Text)
Nothing -> Maybe (Text, Text) -> Cli (Maybe (Text, Text))
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Text, Text)
forall a. Maybe a
Nothing
        Just (Text
subject, Text
content) -> Maybe (Text, Text) -> Cli (Maybe (Text, Text))
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, Text) -> Cli (Maybe (Text, Text)))
-> Maybe (Text, Text) -> Cli (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
subject, Text
content)
  case Maybe (Text, Text)
maySubjectContent of
    Just (Text
subject, Text
content) -> do
      UTCTime
createdAt <- IO UTCTime -> Cli UTCTime
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> Cli UTCTime) -> IO UTCTime -> Cli UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
Time.getCurrentTime
      let historyComment :: HistoryComment UTCTime KeyThumbprint CausalHash HistoryCommentHash
historyComment =
            HistoryComment UTCTime KeyThumbprint CausalHash ()
-> HistoryComment
     UTCTime KeyThumbprint CausalHash HistoryCommentHash
forall any.
HistoryComment UTCTime KeyThumbprint CausalHash any
-> HistoryComment
     UTCTime KeyThumbprint CausalHash HistoryCommentHash
hashHistoryComment (HistoryComment UTCTime KeyThumbprint CausalHash ()
 -> HistoryComment
      UTCTime KeyThumbprint CausalHash HistoryCommentHash)
-> HistoryComment UTCTime KeyThumbprint CausalHash ()
-> HistoryComment
     UTCTime KeyThumbprint CausalHash HistoryCommentHash
forall a b. (a -> b) -> a -> b
$
              HistoryComment
                { $sel:author:HistoryComment :: Text
author =
                    AuthorName -> Text
Config.unAuthorName AuthorName
authorName,
                  $sel:commentId:HistoryComment :: ()
commentId = (),
                  $sel:causal:HistoryComment :: CausalHash
causal = CausalHash
causalHash,
                  UTCTime
createdAt :: UTCTime
$sel:createdAt:HistoryComment :: UTCTime
createdAt,
                  KeyThumbprint
authorThumbprint :: KeyThumbprint
$sel:authorThumbprint:HistoryComment :: KeyThumbprint
authorThumbprint
                }
      let historyCommentRevision :: HistoryCommentRevision
  HistoryCommentRevisionHash UTCTime HistoryCommentHash
historyCommentRevision =
            HistoryCommentRevision () UTCTime HistoryCommentHash
-> HistoryCommentRevision
     HistoryCommentRevisionHash UTCTime HistoryCommentHash
forall any.
HistoryCommentRevision any UTCTime HistoryCommentHash
-> HistoryCommentRevision
     HistoryCommentRevisionHash UTCTime HistoryCommentHash
hashHistoryCommentRevision (HistoryCommentRevision () UTCTime HistoryCommentHash
 -> HistoryCommentRevision
      HistoryCommentRevisionHash UTCTime HistoryCommentHash)
-> HistoryCommentRevision () UTCTime HistoryCommentHash
-> HistoryCommentRevision
     HistoryCommentRevisionHash UTCTime HistoryCommentHash
forall a b. (a -> b) -> a -> b
$
              HistoryCommentRevision
                { $sel:revisionId:HistoryCommentRevision :: ()
revisionId = (),
                  Text
$sel:subject:HistoryCommentRevision :: Text
subject :: Text
subject,
                  Text
$sel:content:HistoryCommentRevision :: Text
content :: Text
content,
                  UTCTime
createdAt :: UTCTime
$sel:createdAt:HistoryCommentRevision :: UTCTime
createdAt,
                  -- Hard coded for now, we can change this later if we want to support hiding comments
                  $sel:isHidden:HistoryCommentRevision :: Bool
isHidden = Bool
False,
                  $sel:authorSignature:HistoryCommentRevision :: ByteString
authorSignature = ByteString
"",
                  $sel:comment:HistoryCommentRevision :: HistoryCommentHash
comment = HistoryComment UTCTime KeyThumbprint CausalHash HistoryCommentHash
historyComment.commentId
                }
      let historyComment' :: HistoryComment
  UTCTime KeyThumbprint CausalHashId HistoryCommentHash
historyComment' = HistoryComment UTCTime KeyThumbprint CausalHash HistoryCommentHash
historyComment {causal = causalHashId}
      let historyCommentRevisionHashBytes :: ByteString
historyCommentRevisionHashBytes =
            HistoryCommentRevision
  HistoryCommentRevisionHash UTCTime HistoryCommentHash
historyCommentRevision.revisionId
              HistoryCommentRevisionHash
-> (HistoryCommentRevisionHash -> Hash) -> Hash
forall a b. a -> (a -> b) -> b
& HistoryCommentRevisionHash -> Hash
unHistoryCommentRevisionHash
              Hash -> (Hash -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Hash -> ByteString
Hash.toByteString
      PK.PersonalKeySignature ByteString
authorSignature <-
        PersonalPrivateKey
-> ByteString -> Cli (Either Error PersonalKeySignature)
forall (m :: * -> *).
MonadIO m =>
PersonalPrivateKey
-> ByteString -> m (Either Error PersonalKeySignature)
PK.signWithPersonalKey PersonalPrivateKey
personalKey ByteString
historyCommentRevisionHashBytes Cli (Either Error PersonalKeySignature)
-> (Either Error PersonalKeySignature -> Cli PersonalKeySignature)
-> Cli PersonalKeySignature
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left Error
err -> Output -> Cli PersonalKeySignature
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli PersonalKeySignature)
-> Output -> Cli PersonalKeySignature
forall a b. (a -> b) -> a -> b
$ Text -> Output
CommentFailed (String -> Text
Text.pack (Error -> String
forall a. Show a => a -> String
show Error
err))
          Right PersonalKeySignature
sig -> PersonalKeySignature -> Cli PersonalKeySignature
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PersonalKeySignature
sig
      Transaction () -> Cli ()
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction () -> Cli ()) -> Transaction () -> Cli ()
forall a b. (a -> b) -> a -> b
$ LatestHistoryComment
  KeyThumbprint
  CausalHashId
  HistoryCommentRevisionHash
  HistoryCommentHash
-> Transaction ()
Q.commentOnCausal (LatestHistoryComment
   KeyThumbprint
   CausalHashId
   HistoryCommentRevisionHash
   HistoryCommentHash
 -> Transaction ())
-> LatestHistoryComment
     KeyThumbprint
     CausalHashId
     HistoryCommentRevisionHash
     HistoryCommentHash
-> Transaction ()
forall a b. (a -> b) -> a -> b
$ HistoryCommentRevision
  HistoryCommentRevisionHash UTCTime HistoryCommentHash
historyCommentRevision {comment = historyComment', authorSignature = authorSignature}
      Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ Output
CommentedSuccessfully
    Maybe (Text, Text)
Nothing -> Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ Output
CommentAborted
  where
    commentInstructions :: Text
commentInstructions =
      Text
[r|
-- Enter your comment, then save and quit your editor to continue.
-- Lines that start with '--' will be ignored.|]

unisonEditorEnvVar :: String
unisonEditorEnvVar :: String
unisonEditorEnvVar = String
"UNISON_EDITOR"

editorEnvVar :: String
editorEnvVar :: String
editorEnvVar = String
"EDITOR"

getEditorProgram :: (MonadIO m) => m (Maybe FilePath)
getEditorProgram :: forall (m :: * -> *). MonadIO m => m (Maybe String)
getEditorProgram = MaybeT m String -> m (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m String -> m (Maybe String))
-> MaybeT m String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
  String -> MaybeT m String
forall {m :: * -> *}. MonadIO m => String -> MaybeT m String
fromEnvVar String
unisonEditorEnvVar
    MaybeT m String -> MaybeT m String -> MaybeT m String
forall a. MaybeT m a -> MaybeT m a -> MaybeT m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> MaybeT m String
forall {m :: * -> *}. MonadIO m => String -> MaybeT m String
fromEnvVar String
editorEnvVar
    MaybeT m String -> MaybeT m String -> MaybeT m String
forall a. MaybeT m a -> MaybeT m a -> MaybeT m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> MaybeT m String
forall {m :: * -> *}. MonadIO m => String -> MaybeT m String
fromEnvVar String
"VISUAL"
    MaybeT m String -> MaybeT m String -> MaybeT m String
forall a. MaybeT m a -> MaybeT m a -> MaybeT m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (Maybe String) -> MaybeT m String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> m (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
findExecutable String
"nano")
    MaybeT m String -> MaybeT m String -> MaybeT m String
forall a. MaybeT m a -> MaybeT m a -> MaybeT m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (Maybe String) -> MaybeT m String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> m (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
findExecutable String
"vi")
  where
    fromEnvVar :: String -> MaybeT m String
fromEnvVar String
var = do
      String
progName <- m (Maybe String) -> MaybeT m String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe String) -> MaybeT m String)
-> m (Maybe String) -> MaybeT m String
forall a b. (a -> b) -> a -> b
$ String -> m (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
Env.lookupEnv String
var
      Bool -> MaybeT m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
progName))
      m (Maybe String) -> MaybeT m String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe String) -> MaybeT m String)
-> m (Maybe String) -> MaybeT m String
forall a b. (a -> b) -> a -> b
$ String -> m (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
findExecutable String
progName

-- | Trigger the user's preferred editing workflow to edit a message, using the provided message to pre-populate the editor.
-- Returns Nothing if the editor was closed with a non-zero exit code, or the message is empty.
editMessage :: (MonadUnliftIO m) => Maybe Text -> m (Maybe (Text, Text))
editMessage :: forall (m :: * -> *).
MonadUnliftIO m =>
Maybe Text -> m (Maybe (Text, Text))
editMessage Maybe Text
initialMessage = MaybeT m (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
  String
editorProg <- m (Maybe String) -> MaybeT m String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT m (Maybe String)
forall (m :: * -> *). MonadIO m => m (Maybe String)
getEditorProgram
  m (Maybe (Text, Text)) -> MaybeT m (Text, Text)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe (Text, Text)) -> MaybeT m (Text, Text))
-> m (Maybe (Text, Text)) -> MaybeT m (Text, Text)
forall a b. (a -> b) -> a -> b
$ String
-> (String -> Handle -> m (Maybe (Text, Text)))
-> m (Maybe (Text, Text))
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (String -> Handle -> m a) -> m a
UnliftIO.withSystemTempFile String
"ucm-history-comment" ((String -> Handle -> m (Maybe (Text, Text)))
 -> m (Maybe (Text, Text)))
-> (String -> Handle -> m (Maybe (Text, Text)))
-> m (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ \String
tempFilePath Handle
tempHandle -> MaybeT m (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    -- Write the initial message to the temp file, if any
    IO () -> MaybeT m ()
forall a. IO a -> MaybeT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT m ()) -> IO () -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ Maybe Text -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
initialMessage ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
msg -> Handle -> Text -> IO ()
Text.hPutStrLn Handle
tempHandle Text
msg
    Handle -> MaybeT m ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
UnliftIO.hClose Handle
tempHandle
    -- Launch the editor on the temp file
    IO (Either SomeException ()) -> MaybeT m (Either SomeException ())
forall a. IO a -> MaybeT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UnliftIO.tryAny (String -> [String] -> IO ()
forall (m :: * -> *). MonadIO m => String -> [String] -> m ()
Proc.callProcess String
editorProg [String
tempFilePath])) MaybeT m (Either SomeException ())
-> (Either SomeException () -> MaybeT m ()) -> MaybeT m ()
forall a b. MaybeT m a -> (a -> MaybeT m b) -> MaybeT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left SomeException
_ -> MaybeT m ()
forall a. MaybeT m a
forall (f :: * -> *) a. Alternative f => f a
empty
      Right () -> () -> MaybeT m ()
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Text
result <- IO Text -> MaybeT m Text
forall a. IO a -> MaybeT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Text
readUtf8 String
tempFilePath)
    let (Text
subject, Text
contents) = Text -> (Text, Text)
cleanComment Text
result
    Bool -> MaybeT m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT m ()) -> Bool -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Text -> Bool
Text.null Text
subject)
    (Text, Text) -> MaybeT m (Text, Text)
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
subject, Text
contents)

cleanComment :: Text -> (Text, Text)
cleanComment :: Text -> (Text, Text)
cleanComment Text
txt =
  Text
txt
    Text -> (Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& Text -> [Text]
Text.lines
    [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Bool
Text.isPrefixOf Text
"--")
    [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& [Text] -> Text
Text.unlines
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text
Text.strip
    Text -> (Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& Text -> [Text]
Text.lines
    [Text] -> ([Text] -> (Text, Text)) -> (Text, Text)
forall a b. a -> (a -> b) -> b
& \case
      [] -> (Text
"", Text
"")
      (Text
s : [Text]
rest) -> (Text -> Text
Text.strip Text
s, Text -> Text
Text.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines [Text]
rest)