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

import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Text.RawString.QQ (r)
import U.Codebase.Config qualified as Config
import U.Codebase.Sqlite.HistoryComment (HistoryComment (..))
import U.Codebase.Sqlite.Queries qualified as Q
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.Prelude
import UnliftIO qualified
import UnliftIO.Directory (findExecutable)
import UnliftIO.Environment qualified as Env
import UnliftIO.Process qualified as Proc

handleHistoryComment :: Maybe BranchId2 -> Cli ()
handleHistoryComment :: Maybe BranchId2 -> Cli ()
handleHistoryComment Maybe BranchId2
mayThingToAnnotate = do
  AuthorName
authorName <-
    Transaction (Maybe AuthorName) -> Cli (Maybe AuthorName)
forall a. Transaction a -> Cli a
Cli.runTransaction Transaction (Maybe AuthorName)
Q.getAuthorName Cli (Maybe AuthorName)
-> (Maybe AuthorName -> Cli AuthorName) -> Cli AuthorName
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      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 (HistoryComment CausalHashId HistoryCommentId)
mayHistoryComment) <- Transaction
  (CausalHashId,
   Maybe (HistoryComment CausalHashId HistoryCommentId))
-> Cli
     (CausalHashId,
      Maybe (HistoryComment CausalHashId HistoryCommentId))
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction
   (CausalHashId,
    Maybe (HistoryComment CausalHashId HistoryCommentId))
 -> Cli
      (CausalHashId,
       Maybe (HistoryComment CausalHashId HistoryCommentId)))
-> Transaction
     (CausalHashId,
      Maybe (HistoryComment CausalHashId HistoryCommentId))
-> Cli
     (CausalHashId,
      Maybe (HistoryComment CausalHashId HistoryCommentId))
forall a b. (a -> b) -> a -> b
$ do
    CausalHashId
causalHashId <- CausalHash -> Transaction CausalHashId
Q.expectCausalHashIdByCausalHash CausalHash
causalHash
    Maybe (HistoryComment CausalHashId HistoryCommentId)
mayExistingCommentInfo <- CausalHashId
-> Transaction
     (Maybe (HistoryComment CausalHashId HistoryCommentId))
Q.getLatestCausalComment CausalHashId
causalHashId
    (CausalHashId,
 Maybe (HistoryComment CausalHashId HistoryCommentId))
-> Transaction
     (CausalHashId,
      Maybe (HistoryComment CausalHashId HistoryCommentId))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CausalHashId
causalHashId, Maybe (HistoryComment CausalHashId HistoryCommentId)
mayExistingCommentInfo)
  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
        HistoryComment {Text
subject :: Text
$sel:subject:HistoryComment :: forall causal id. HistoryComment causal id -> Text
subject, Text
content :: Text
$sel:content:HistoryComment :: forall causal id. HistoryComment causal id -> Text
content} <- Maybe (HistoryComment CausalHashId HistoryCommentId)
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 -> Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ Output
CommentAborted
    Just (Text
subject, Text
content) -> do
      let historyComment :: HistoryComment CausalHashId ()
historyComment = HistoryComment {$sel:author:HistoryComment :: Text
author = AuthorName -> Text
Config.unAuthorName AuthorName
authorName, Text
$sel:subject:HistoryComment :: Text
subject :: Text
subject, Text
$sel:content:HistoryComment :: Text
content :: Text
content, $sel:commentId:HistoryComment :: ()
commentId = (), $sel:causal:HistoryComment :: CausalHashId
causal = CausalHashId
causalHashId}
      Transaction () -> Cli ()
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction () -> Cli ()) -> Transaction () -> Cli ()
forall a b. (a -> b) -> a -> b
$ HistoryComment CausalHashId () -> Transaction ()
Q.commentOnCausal HistoryComment CausalHashId ()
historyComment
      Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ Output
CommentedSuccessfully
  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 cleanedResult :: Text
cleanedResult =
          Text
result
            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
    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
cleanedResult)
    let (Text
subject, Text
contents) =
          case Text -> [Text]
Text.lines Text
cleanedResult of
            [] -> (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)
    (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)