diff --git a/codebase2/codebase-sqlite/U/Codebase/Config.hs b/codebase2/codebase-sqlite/U/Codebase/Config.hs new file mode 100644 index 0000000000..9d7c325128 --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Config.hs @@ -0,0 +1,49 @@ +module U.Codebase.Config + ( AuthorName, + ConfigKey (..), + allKeys, + mkAuthorName, + unAuthorName, + keyToText, + keyFromText, + allKeysText, + ) +where + +import Data.Text qualified as Text +import Unison.Prelude +import Unison.Sqlite qualified as Sqlite + +data ConfigKey = AuthorNameKey + deriving stock (Eq, Enum, Bounded) + +instance Show ConfigKey where + show k = Text.unpack . keyToText $ k + +allKeys :: [ConfigKey] +allKeys = [minBound .. maxBound] + +allKeysText :: [Text] +allKeysText = keyToText <$> allKeys + +keyToText :: ConfigKey -> Text +keyToText = \case + AuthorNameKey -> "author.name" + +keyFromText :: Text -> Maybe ConfigKey +keyFromText t = case t of + "author.name" -> Just AuthorNameKey + _ -> Nothing + +instance Sqlite.ToField ConfigKey where + toField AuthorNameKey = Sqlite.toField (keyToText AuthorNameKey) + +mkAuthorName :: Text -> Either Text AuthorName +mkAuthorName name + | Text.null (Text.strip name) = Left "Author name cannot be empty." + | Text.length name > 100 = Left "Author name cannot exceed 100 characters." + | otherwise = Right (AuthorName name) + +newtype AuthorName = AuthorName {unAuthorName :: Text} + deriving stock (Eq, Show) + deriving newtype (Sqlite.ToField, Sqlite.FromField) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs index 8dedcfbe25..1cb0d95f5f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs @@ -66,3 +66,7 @@ instance Show BranchHashId where instance Show CausalHashId where show h = "CausalHashId (" ++ show (unCausalHashId h) ++ ")" + +newtype HistoryCommentId = HistoryCommentId Word64 + deriving (Eq, Ord, Show) + deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via Word64 diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/HistoryComment.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/HistoryComment.hs new file mode 100644 index 0000000000..b9c24c5c10 --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/HistoryComment.hs @@ -0,0 +1,11 @@ +module U.Codebase.Sqlite.HistoryComment (HistoryComment (..)) where + +import Data.Text (Text) + +data HistoryComment id = HistoryComment + { author :: Text, + subject :: Text, + content :: Text, + commentId :: id + } + deriving (Show, Eq, Functor) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 658381fbe6..e667e20c10 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -233,6 +233,10 @@ module U.Codebase.Sqlite.Queries expectCurrentProjectPath, setCurrentProjectPath, + -- * History Comments + commentOnCausal, + getLatestCausalComment, + -- * migrations runCreateSql, addTempEntityTables, @@ -254,6 +258,7 @@ module U.Codebase.Sqlite.Queries addUpdateBranchTable, addDerivedDependentsByDependencyIndex, addUpgradeBranchTable, + addHistoryComments, -- ** schema version currentSchemaVersion, @@ -284,6 +289,12 @@ module U.Codebase.Sqlite.Queries x2cDecl, checkBranchExistsForCausalHash, + -- * Config + getAuthorName, + setAuthorName, + getConfigValue, + setConfigValue, + -- * Types TextPathSegments, JsonParseFailure (..), @@ -319,6 +330,8 @@ import Data.Time qualified as Time import Data.Vector qualified as Vector import Network.URI (URI) import U.Codebase.Branch.Type (NamespaceStats (..)) +import U.Codebase.Config (AuthorName, ConfigKey) +import U.Codebase.Config qualified as Config import U.Codebase.Decl qualified as C import U.Codebase.Decl qualified as C.Decl import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) @@ -336,6 +349,7 @@ import U.Codebase.Sqlite.DbId CausalHashId (..), HashId (..), HashVersion, + HistoryCommentId, ObjectId (..), PatchObjectId (..), ProjectBranchId (..), @@ -351,6 +365,7 @@ import U.Codebase.Sqlite.Decode import U.Codebase.Sqlite.Entity (SyncEntity) import U.Codebase.Sqlite.Entity qualified as Entity import U.Codebase.Sqlite.HashHandle (HashHandle (..)) +import U.Codebase.Sqlite.HistoryComment (HistoryComment (..)) import U.Codebase.Sqlite.LocalIds ( LocalDefnId (..), LocalIds, @@ -413,7 +428,7 @@ type TextPathSegments = [Text] -- * main squeeze currentSchemaVersion :: SchemaVersion -currentSchemaVersion = 22 +currentSchemaVersion = 23 runCreateSql :: Transaction () runCreateSql = @@ -499,6 +514,10 @@ addUpgradeBranchTable :: Transaction () addUpgradeBranchTable = executeStatements $(embedProjectStringFile "sql/019-add-upgrade-branch-table.sql") +addHistoryComments :: Transaction () +addHistoryComments = + executeStatements $(embedProjectStringFile "sql/020-add-history-comments.sql") + schemaVersion :: Transaction SchemaVersion schemaVersion = queryOneCol @@ -4022,3 +4041,73 @@ saveSquashResult bhId chId = ) ON CONFLICT DO NOTHING |] + +getLatestCausalComment :: + CausalHashId -> + Transaction (Maybe (HistoryComment HistoryCommentId)) +getLatestCausalComment causalHashId = + queryMaybeRow @(Text, Text, Text, HistoryCommentId) + [sql| + SELECT cc.id, ccr.contents + FROM change_comments AS cc + JOIN change_comment_revisions AS ccr ON cc.id = ccr.comment_id + WHERE cc.causal_hash_id = :causalHashId + ORDER BY ccr.created_at DESC + LIMIT 1 + |] + <&> fmap \(author, subject, content, commentId) -> + HistoryComment {author, subject, content, commentId} + +commentOnCausal :: AuthorName -> CausalHashId -> Text -> Transaction () +commentOnCausal authorName causalHashId contents = do + mayExistingCommentId <- + queryMaybeCol @HistoryCommentId + [sql| + SELECT id + FROM change_comments + WHERE causal_hash_id = :causalHashId + |] + commentId <- case mayExistingCommentId of + Nothing -> + queryOneCol @HistoryCommentId + [sql| + INSERT INTO change_comments (author, causal_hash_id, created_at) + VALUES (:authorName, :causalHashId, strftime('%s', 'now', 'subsec')) + RETURNING id + |] + Just cid -> pure cid + execute + [sql| + INSERT INTO change_comment_revisions (comment_id, contents, created_at) + VALUES (:commentId, :contents, strftime('%s', 'now', 'subsec')) + |] + +getAuthorName :: Transaction (Maybe AuthorName) +getAuthorName = do + r <- getConfigValue Config.AuthorNameKey <&> fmap Config.mkAuthorName + case r of + Just (Left err) -> error $ "getAuthorName: " <> Text.unpack err + Just (Right authorName) -> pure (Just authorName) + Nothing -> pure Nothing + +setAuthorName :: AuthorName -> Transaction () +setAuthorName authorName = + setConfigValue Config.AuthorNameKey (Config.unAuthorName authorName) + +setConfigValue :: ConfigKey -> Text -> Transaction () +setConfigValue key value = + execute + [sql| + INSERT INTO config (key, value) + VALUES (:key, :value) + ON CONFLICT (key) DO UPDATE SET value = excluded.value + |] + +getConfigValue :: ConfigKey -> Transaction (Maybe Text) +getConfigValue key = + queryMaybeCol + [sql| + SELECT value + FROM config + WHERE key = :key + |] diff --git a/codebase2/codebase-sqlite/sql/020-add-history-comments.sql b/codebase2/codebase-sqlite/sql/020-add-history-comments.sql new file mode 100644 index 0000000000..d4c04c4672 --- /dev/null +++ b/codebase2/codebase-sqlite/sql/020-add-history-comments.sql @@ -0,0 +1,38 @@ +-- A simple table for storing user preferences as key/value pairs. +CREATE TABLE config ( + key TEXT NOT NULL PRIMARY KEY, + value TEXT NOT NULL +); + +-- Add tables for storing change comments +-- These tables deliberately contain less information than we'll probably need, with the +-- plan that we'll migrate them and add new features on the way. + +CREATE TABLE change_comments ( + id INTEGER PRIMARY KEY, + causal_hash_id INTEGER REFERENCES hash(id) NOT NULL, + author TEXT NOT NULL, + + -- Remember that SQLITE doesn't have any actual 'time' type, + -- This column contains float values constructed + -- using strftime('%s', 'now', 'subsec') + created_at TEXT NOT NULL +); + +CREATE INDEX change_comments_by_causal_hash_id ON change_comments(causal_hash_id, created_at DESC); + +CREATE TABLE change_comment_revisions ( + comment_id INTEGER REFERENCES change_comments(id), + contents TEXT NOT NULL, + + -- Remember that SQLITE doesn't have any actual 'time' type, + -- This column contains float values constructed + -- using strftime('%s', 'now', 'subsec') + created_at TEXT NOT NULL, + + -- - In a distributed system you really can’t ever truly delete comments, + -- but you can ask to hide them. + hidden BOOL NOT NULL DEFAULT FALSE +); + +CREATE INDEX change_comment_revisions_by_comment_id_and_created_at ON change_comment_revisions(comment_id, created_at DESC); diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 79f9c09eda..f6dc340e7c 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack @@ -29,6 +29,7 @@ extra-source-files: sql/017-add-update-branch-table.sql sql/018-add-derived-dependents-by-dependency-index.sql sql/019-add-upgrade-branch-table.sql + sql/020-add-history-comments.sql sql/create.sql source-repository head @@ -39,6 +40,7 @@ library exposed-modules: U.Codebase.Branch U.Codebase.Causal.Squash + U.Codebase.Config U.Codebase.Sqlite.Branch.Diff U.Codebase.Sqlite.Branch.Format U.Codebase.Sqlite.Branch.Full @@ -48,6 +50,7 @@ library U.Codebase.Sqlite.Decode U.Codebase.Sqlite.Entity U.Codebase.Sqlite.HashHandle + U.Codebase.Sqlite.HistoryComment U.Codebase.Sqlite.LocalIds U.Codebase.Sqlite.LocalizeObject U.Codebase.Sqlite.ObjectType diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index 9eaeb6a8de..c39b90fee5 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -89,7 +89,8 @@ migrations regionVar getDeclType termBuffer declBuffer rootCodebasePath = sqlMigration 19 Q.addMergeBranchTables, sqlMigration 20 Q.addUpdateBranchTable, sqlMigration 21 Q.addDerivedDependentsByDependencyIndex, - sqlMigration 22 Q.addUpgradeBranchTable + sqlMigration 22 Q.addUpgradeBranchTable, + sqlMigration 23 Q.addHistoryComments ] where runT :: Sqlite.Transaction () -> Sqlite.Connection -> IO () diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index e95091a164..366e9bb8fd 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -85,6 +85,7 @@ createSchema = do Q.addUpdateBranchTable Q.addDerivedDependentsByDependencyIndex Q.addUpgradeBranchTable + Q.addHistoryComments (_, emptyCausalHashId) <- emptyCausalHash (_, ProjectBranchRow {projectId, branchId}) <- insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index a2217b6d23..3522a51b03 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack @@ -139,8 +139,8 @@ library Unison.Typechecker.TypeError Unison.Typechecker.TypeLookup Unison.Typechecker.TypeVar - Unison.UnconflictedLocalDefnsView Unison.Typechecker.Variance + Unison.UnconflictedLocalDefnsView Unison.UnisonFile Unison.UnisonFile.Env Unison.UnisonFile.Names diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index d41cdefca1..8d8ccb386d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -50,6 +50,7 @@ import Unison.Codebase.Editor.HandleInput.BranchRename (handleBranchRename) import Unison.Codebase.Editor.HandleInput.BranchSquash (handleBranchSquash) import Unison.Codebase.Editor.HandleInput.Branches (handleBranches) import Unison.Codebase.Editor.HandleInput.Cancel (handleCancel) +import Unison.Codebase.Editor.HandleInput.ConfigSet (handleConfigSet) import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition import Unison.Codebase.Editor.HandleInput.DebugFoldRanges qualified as DebugFoldRanges import Unison.Codebase.Editor.HandleInput.DebugSynhashTerm (handleDebugSynhashTerm) @@ -64,6 +65,8 @@ import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace) import Unison.Codebase.Editor.HandleInput.FindAndReplace (handleStructuredFindI, handleStructuredFindReplaceI, handleTextFindI) import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Format import Unison.Codebase.Editor.HandleInput.Global qualified as Global +import Unison.Codebase.Editor.HandleInput.History (handleHistory) +import Unison.Codebase.Editor.HandleInput.HistoryComment (handleHistoryComment) import Unison.Codebase.Editor.HandleInput.InstallLib (handleInstallLib, handleInstallLocalLib) import Unison.Codebase.Editor.HandleInput.LSPDebug qualified as LSPDebug import Unison.Codebase.Editor.HandleInput.Load (EvalMode (Sandboxed), evalUnisonFile, handleLoad, loadUnisonFile) @@ -297,29 +300,9 @@ loop e = do success <- Cli.popd when (not success) (Cli.respond StartOfCurrentPathHistory) HistoryI resultsCap diffCap from -> do - branch <- - case from of - BranchAtSCH hash -> Cli.resolveShortCausalHash hash - BranchAtPath path' -> do - pp <- Cli.resolvePath' path' - Cli.getBranchFromProjectPath pp - BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp - schLength <- Cli.runTransaction Codebase.branchHashLength - history <- liftIO (doHistory schLength 0 branch []) - Cli.respondNumbered history - where - doHistory :: Int -> Int -> Branch IO -> [(CausalHash, Names.Diff)] -> IO NumberedOutput - doHistory schLength !n b acc = - if maybe False (n >=) resultsCap - then pure (History diffCap schLength acc (PageEnd (Branch.headHash b) n)) - else case Branch._history b of - Causal.One {} -> pure (History diffCap schLength acc (EndOfLog $ Branch.headHash b)) - Causal.Merge _ _ _ tails -> - pure (History diffCap schLength acc (MergeTail (Branch.headHash b) $ Map.keys tails)) - Causal.Cons _ _ _ tail -> do - b' <- fmap Branch.Branch $ snd tail - let elem = (Branch.headHash b, Branch.namesDiff b' b) - doHistory schLength (n + 1) b' (elem : acc) + handleHistory resultsCap diffCap from + HistoryCommentI toAnnotate -> do + handleHistoryComment toAnnotate UndoI -> do rootBranch <- Cli.getCurrentProjectRoot (_, prev) <- @@ -736,6 +719,7 @@ loop e = do BranchRenameI name -> handleBranchRename name BranchesI name -> handleBranches name CloneI remoteNames localNames -> handleClone remoteNames localNames + ConfigSetI key value -> handleConfigSet key value BranchSquashI branchToSquash destBranch -> handleBranchSquash branchToSquash destBranch ReleaseDraftI semver -> handleReleaseDraft semver UpgradeI old new -> handleUpgrade old new @@ -817,6 +801,7 @@ inputDescription input = BranchesI {} -> wat ClearI {} -> wat CloneI {} -> wat + ConfigSetI {} -> wat CreateMessage {} -> wat DebugClearWatchI {} -> wat DebugDoctorI {} -> wat @@ -842,6 +827,7 @@ inputDescription input = HistoryI {} -> wat IOTestAllI -> wat IOTestI {} -> wat + HistoryCommentI {} -> wat LibInstallI {} -> wat LibInstallLocalI {} -> wat ListDependenciesI {} -> wat diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ConfigSet.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ConfigSet.hs new file mode 100644 index 0000000000..bea2fd165b --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ConfigSet.hs @@ -0,0 +1,11 @@ +module Unison.Codebase.Editor.HandleInput.ConfigSet (handleConfigSet) where + +import U.Codebase.Config (ConfigKey) +import U.Codebase.Sqlite.Queries qualified as Q +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Prelude + +handleConfigSet :: ConfigKey -> Text -> Cli () +handleConfigSet key value = do + Cli.runTransaction $ Q.setConfigValue key value diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/History.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/History.hs new file mode 100644 index 0000000000..18f3aafba6 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/History.hs @@ -0,0 +1,56 @@ +module Unison.Codebase.Editor.HandleInput.History (handleHistory) where + +import Data.Map qualified as Map +import U.Codebase.HashTags +import U.Codebase.Sqlite.HistoryComment (HistoryComment) +import U.Codebase.Sqlite.Queries qualified as Q +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch +import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.Causal qualified as Causal +import Unison.Codebase.Editor.Input +import Unison.Codebase.Editor.Output +import Unison.Codebase.Path (Path') +import Unison.NamesWithHistory qualified as Names +import Unison.Prelude + +handleHistory :: Maybe Int -> Maybe Int -> BranchIdG Path' -> Cli.Cli () +handleHistory resultsCap diffCap from = do + branch <- + case from of + BranchAtSCH hash -> Cli.resolveShortCausalHash hash + BranchAtPath path' -> do + pp <- Cli.resolvePath' path' + Cli.getBranchFromProjectPath pp + BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp + schLength <- Cli.runTransaction Codebase.branchHashLength + history <- doHistory schLength 0 branch [] + Cli.respondNumbered history + where + doHistory :: Int -> Int -> Branch IO -> [(CausalHash, Maybe (HistoryComment ()), Names.Diff)] -> Cli.Cli NumberedOutput + doHistory schLength !n b acc = + if maybe False (n >=) resultsCap + then do + mayComment <- getComment $ Branch.headHash b + pure (History diffCap schLength acc (mayComment, PageEnd (Branch.headHash b) n)) + else case Branch._history b of + Causal.One {} -> do + mayComment <- getComment $ Branch.headHash b + pure (History diffCap schLength acc (mayComment, EndOfLog $ Branch.headHash b)) + Causal.Merge _ _ _ tails -> do + mayComment <- getComment $ Branch.headHash b + pure (History diffCap schLength acc (mayComment, MergeTail (Branch.headHash b) $ Map.keys tails)) + Causal.Cons _ _ _ tail -> do + b' <- liftIO $ fmap Branch.Branch $ snd tail + let causalHash = Branch.headHash b + mayComment <- getComment causalHash + let elem = (causalHash, mayComment, Branch.namesDiff b' b) + doHistory schLength (n + 1) b' (elem : acc) + getComment :: CausalHash -> Cli.Cli (Maybe (HistoryComment ())) + getComment ch = Cli.runTransaction $ do + causalHashId <- Q.expectCausalHashIdByCausalHash ch + Q.getLatestCausalComment causalHashId + <&> fmap void diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/HistoryComment.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/HistoryComment.hs new file mode 100644 index 0000000000..f66d290525 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/HistoryComment.hs @@ -0,0 +1,106 @@ +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.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 mayThingToAnnotate = do + authorName <- + Cli.runTransaction Q.getAuthorName >>= \case + Nothing -> Cli.returnEarly $ AuthorNameRequired + Just authorName -> pure authorName + causalHash <- case mayThingToAnnotate of + Nothing -> do + Branch.headHash <$> Cli.getCurrentProjectRoot + Just (Left sch) -> do + Cli.runTransactionWithRollback \rollback -> Cli.resolveShortCausalHashToCausalHash rollback sch + Just (Right brp) -> case brp of + BranchPathInCurrentProject projectBranchName path + | path == Path.Root -> do + pab <- ProjectUtils.resolveProjectBranch (ProjectAndBranch Nothing (Just projectBranchName)) + Cli.runTransaction $ ProjectUtils.getProjectBranchCausalHash pab.branch + | otherwise -> Cli.returnEarly $ InvalidCommentTarget "commenting on paths is currently unsupported." + QualifiedBranchPath projectName projectBranchName path + | path == Path.Root -> do + pab <- ProjectUtils.resolveProjectBranch (ProjectAndBranch (Just projectName) (Just projectBranchName)) + Cli.runTransaction $ ProjectUtils.getProjectBranchCausalHash pab.branch + | otherwise -> Cli.returnEarly $ InvalidCommentTarget "commenting on paths is currently unsupported." + UnqualifiedPath {} -> Cli.returnEarly $ InvalidCommentTarget "commenting on paths is currently unsupported." + (causalHashId, mayHistoryComment) <- Cli.runTransaction $ do + causalHashId <- Q.expectCausalHashIdByCausalHash causalHash + mayExistingCommentInfo <- Q.getLatestCausalComment causalHashId + pure (causalHashId, mayExistingCommentInfo) + let populatedMsg = fromMaybe commentInstructions $ do + HistoryComment {subject, content} <- mayHistoryComment + pure $ Text.unlines [subject, "", content, commentInstructions] + mayNewMessage <- liftIO (editMessage (Just populatedMsg)) + case mayNewMessage of + Nothing -> Cli.respond $ CommentAborted + Just newMessage -> do + Cli.runTransaction $ Q.commentOnCausal authorName causalHashId newMessage + Cli.respond $ CommentedSuccessfully + where + commentInstructions = + [r| +-- Enter your comment, then save and quit your editor to continue. +-- Lines that start with '--' will be ignored.|] + +unisonEditorEnvVar :: String +unisonEditorEnvVar = "UNISON_EDITOR" + +editorEnvVar :: String +editorEnvVar = "EDITOR" + +getEditorProgram :: (MonadIO m) => m (Maybe FilePath) +getEditorProgram = runMaybeT $ do + fromEnvVar unisonEditorEnvVar + <|> fromEnvVar editorEnvVar + <|> fromEnvVar "VISUAL" + <|> MaybeT (findExecutable "nano") + <|> MaybeT (findExecutable "vi") + where + fromEnvVar var = do + progName <- MaybeT $ Env.lookupEnv var + guard (not (null progName)) + MaybeT $ findExecutable 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) +editMessage initialMessage = runMaybeT do + editorProg <- MaybeT getEditorProgram + MaybeT $ UnliftIO.withSystemTempFile "ucm-history-comment" $ \tempFilePath tempHandle -> runMaybeT do + -- Write the initial message to the temp file, if any + liftIO $ for_ initialMessage $ \msg -> Text.hPutStrLn tempHandle msg + UnliftIO.hClose tempHandle + -- Launch the editor on the temp file + liftIO (UnliftIO.tryAny (Proc.callProcess editorProg [tempFilePath])) >>= \case + Left _ -> empty + Right () -> pure () + result <- liftIO (readUtf8 tempFilePath) + let cleanedResult = + result + & Text.lines + & filter (not . Text.isPrefixOf "--") + & Text.unlines + & Text.strip + guard $ not (Text.null cleanedResult) + pure cleanedResult diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index c6467402db..1b8f8f7284 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -33,6 +33,7 @@ where import Data.List.NonEmpty (NonEmpty) import Data.Text qualified as Text import Data.These (These) +import U.Codebase.Config (ConfigKey) import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path @@ -163,6 +164,8 @@ data Input | -- First `Maybe Int` is cap on number of results, if any -- Second `Maybe Int` is cap on diff elements shown, if any HistoryI (Maybe Int) (Maybe Int) BranchId + | -- An optional causal hash or branch to annotate. + HistoryCommentI (Maybe BranchId2 {- causal to annotate -}) | -- execute an IO thunk with args; boolean indicates profiling ExecuteI ProfileSpec (HQ.HashQualified Name) [String] | -- save the result of a previous Execute @@ -245,6 +248,7 @@ data Input | EditDependentsI !(HQ.HashQualified Name) | BranchSquashI (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) | CancelI + | ConfigSetI ConfigKey Text deriving (Eq, Show) -- | The source of a `branch` command: what to make the new branch from. diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 91b5f7225e..ab2fa8c324 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -28,6 +28,7 @@ import System.Console.Haskeline qualified as Completion import System.Exit (ExitCode) import U.Codebase.Branch.Diff (NameChanges) import U.Codebase.HashTags (CausalHash) +import U.Codebase.Sqlite.HistoryComment (HistoryComment) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog @@ -130,8 +131,8 @@ data NumberedOutput History (Maybe Int) -- Amount of history to print HashLength - [(CausalHash, Names.Diff)] - HistoryTail -- 'origin point' of this view of history. + [(CausalHash, Maybe (HistoryComment ()), Names.Diff)] + (Maybe (HistoryComment ()), HistoryTail) -- 'origin point' of this view of history. | ListProjects [Sqlite.Project] | ListBranches ProjectName [(ProjectBranchName, [(URI, ProjectName, ProjectBranchName)])] | AmbiguousSwitch ProjectName (ProjectAndBranch ProjectName ProjectBranchName) @@ -453,6 +454,10 @@ data Output | SyncingFromTo CausalHash CausalHash | CantDeleteConstructor !(NESet Name) | CantDoThatDuring !Text {- "an upgrade" / "a merge" -} !Text {- "upgrade" / "merge" -} + | InvalidCommentTarget Text + | CommentedSuccessfully + | CommentAborted + | AuthorNameRequired data MoreEntriesThanShown = MoreEntriesThanShown | AllEntriesShown deriving (Eq, Show) @@ -694,6 +699,10 @@ isFailure o = case o of SyncingFromTo {} -> False CantDeleteConstructor {} -> True CantDoThatDuring {} -> True + InvalidCommentTarget {} -> True + CommentedSuccessfully {} -> False + CommentAborted {} -> True + AuthorNameRequired {} -> True isNumberedFailure :: NumberedOutput -> Bool isNumberedFailure = \case diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 3c9d41c58e..5da3592b07 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -17,6 +17,7 @@ module Unison.CommandLine.Completion completeShareProject, completeShareBranchOrRelease, filenameCompletion, + configKeyCompletion, -- Unused for now, but may be useful later prettyCompletion, ) @@ -41,6 +42,7 @@ import System.Console.Haskeline.Completion qualified as Haskeline import Text.Megaparsec qualified as MP import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal +import U.Codebase.Config qualified as Config import U.Codebase.Reference qualified as Reference import U.Codebase.Referent qualified as Referent import Unison.Auth.HTTPClient (AuthenticatedHttpClient (..)) @@ -639,3 +641,11 @@ filenameCompletion query = do let prefix = reverse query (_leftovers, results) <- Line.completeFilename (prefix, "") pure results + +configKeyCompletion :: + (MonadIO m) => + String -> + m [Completion] +configKeyCompletion query = do + let options = Text.unpack <$> Config.allKeysText + pure $ exactComplete query options diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index d6a7813413..30e5ab43b6 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -15,6 +15,7 @@ module Unison.CommandLine.InputPatterns cd, clear, clone, + configSet, createAuthor, debugClearWatchCache, debugDoctor, @@ -67,6 +68,7 @@ module Unison.CommandLine.InputPatterns help, helpTopics, history, + historyComment, ioTest, ioTestAll, libInstallInputPattern, @@ -154,6 +156,7 @@ import System.Console.Haskeline.Completion qualified as Line import Text.Megaparsec qualified as Megaparsec import Text.Numeral (defaultInflection) import Text.Numeral.Language.ENG qualified as Numeral +import U.Codebase.Config qualified as Config import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Sqlite.DbId (ProjectBranchId) import U.Codebase.Sqlite.Project qualified as Sqlite @@ -1673,6 +1676,36 @@ history = [] -> pure $ Input.HistoryI (Just 10) (Just 10) (BranchAtPath Path.Current') src : _ -> Input.HistoryI (Just 10) (Just 10) <$> handleBranchIdArg src +historyComment :: InputPattern +historyComment = + InputPattern + "history.comment" + ["comment", "comment.history"] + I.Visible + (Parameters [] $ Optional [("hash or branch to create a comment after", namespaceOrProjectBranchArg config)] Nothing) + ( P.wrapColumn2 + [ ( makeExample historyComment [], + "Creates a comment after the head of the current branch." + ), + ( makeExample historyComment ["/main"], + "Creates a comment after the head of the `main` branch." + ) + ] + ) + \case + [] -> pure $ Input.HistoryCommentI Nothing + [src] -> do + target <- handleBranchId2Arg src + pure $ Input.HistoryCommentI (Just target) + _ -> wrongArgsLength "at most one argument" [] + where + config = + ProjectBranchSuggestionsConfig + { showProjectCompletions = False, + projectInclusion = AllProjects, + branchInclusion = AllBranches + } + forkLocal :: InputPattern forkLocal = InputPattern @@ -2415,6 +2448,36 @@ globalReflog = . const $ pure Input.ShowGlobalReflogI +configSet :: InputPattern +configSet = + InputPattern + { patternName = "config.set", + aliases = [], + visibility = I.Visible, + params = Parameters [("key", configKeyArg)] $ OnePlus ("value", noCompletionsArg), + help = + P.lines + [ P.wrap $ + "The" + <> makeExample' configSet + <> "command sets the configuration key to the provided value. E.g.", + "", + (makeExample configSet [P.text $ Config.keyToText Config.AuthorNameKey, "Author Name"]), + "", + P.hang + "Configuration options include:" + (P.wrap . P.text $ Text.intercalate ", " $ Config.allKeysText) + ], + parse = \case + (key : values) -> do + key' <- unsupportedStructuredArgument configSet "a config key" key + values' <- for values (unsupportedStructuredArgument configSet "a config value") + case Config.keyFromText (Text.pack key') of + Nothing -> Left . P.text $ "I don't recognize that config key. Available keys are: " <> Text.intercalate ", " Config.allKeysText + Just pkey -> Right $ Input.ConfigSetI pkey (Text.pack $ unwords values') + args -> wrongArgsLength "exactly two arguments" args + } + edit :: InputPattern edit = InputPattern @@ -3595,6 +3658,7 @@ validInputs = cd, clear, clone, + configSet, createAuthor, debugAliasTermForce, debugAliasTypeForce, @@ -3656,6 +3720,7 @@ validInputs = help, helpTopics, history, + historyComment, ioTest, ioTestAll, libInstallInputPattern, @@ -3858,6 +3923,15 @@ directoryPathArg = isStructured = False } +configKeyArg :: ParameterType +configKeyArg = + ParameterType + { typeName = "config-key", + suggestions = \input _cb _http _p -> configKeyCompletion input, + fzfResolver = Nothing, + isStructured = False + } + _remoteProjectArg :: ParameterType _remoteProjectArg = ParameterType diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 8751a8886e..c6278c9a17 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1,7 +1,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Unison.CommandLine.OutputMessages where @@ -41,6 +40,7 @@ import U.Codebase.Branch (NamespaceStats (..)) import U.Codebase.Branch.Diff (NameChanges (..)) import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Reference qualified as Reference +import U.Codebase.Sqlite.HistoryComment (HistoryComment (..)) import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog @@ -289,12 +289,12 @@ notifyNumbered = \case P.lines [ note $ "The most recent namespace hash is immediately below this message.", "", - P.sep "\n\n" [go i (toSCH h) diff | (i, (h, diff)) <- zip [1 ..] reversedHistory], + P.sep "\n\n" [displayCausal i (toSCH h) mayComment diff | (i, (h, mayComment, diff)) <- zip [1 ..] reversedHistory], "", tailMsg ] branchHashes :: [CausalHash] - branchHashes = (fst <$> reversedHistory) <> tailHashes + branchHashes = (view _1 <$> reversedHistory) <> tailHashes in (msg, SA.Namespace <$> branchHashes) where toSCH :: CausalHash -> ShortCausalHash @@ -302,42 +302,57 @@ notifyNumbered = \case reversedHistory = reverse history showNum :: Int -> Pretty showNum n = P.shown n <> ". " + displayComment :: Bool -> Maybe (HistoryComment ()) -> [Pretty] + displayComment prefixSpacer mayComment = case mayComment of + Nothing -> [] + Just (HistoryComment {author, subject, content}) -> + Monoid.whenM prefixSpacer [""] + <> [ P.bold (P.text author), + P.indent (P.blue (P.text "> ")) (P.yellow $ P.text subject), + P.indent (P.blue (P.text "> ")) (P.text content), + "" + ] handleTail :: Int -> (Pretty, [CausalHash]) handleTail n = case tail of - E.EndOfLog h -> - ( P.lines - [ "□ " <> showNum n <> prettySCH (toSCH h) <> " (start of history)" - ], + (mayComment, E.EndOfLog h) -> + ( P.lines $ + displayComment True mayComment + <> [ "□ " <> showNum n <> prettySCH (toSCH h) <> " (start of history)" + ], [h] ) - E.MergeTail h hs -> - ( P.lines - [ P.wrap $ "This segment of history starts with a merge." <> ex, - "", - "⊙ " <> showNum n <> prettySCH (toSCH h), - "⑃", - P.lines (hs & imap \i h -> showNum (n + 1 + i) <> prettySCH (toSCH h)) - ], + (mayComment, E.MergeTail h hs) -> + ( P.lines $ + displayComment True mayComment + <> [ P.wrap $ "This segment of history starts with a merge." <> ex, + "", + "⊙ " <> showNum n <> prettySCH (toSCH h) + ] + <> [ "⑃", + P.lines (hs & imap \i h -> showNum (n + 1 + i) <> prettySCH (toSCH h)) + ], h : hs ) - E.PageEnd h _n -> - ( P.lines - [ P.wrap $ "There's more history before the versions shown here." <> ex, - "", - dots, - "", - "⊙ " <> showNum n <> prettySCH (toSCH h), - "" - ], + (mayComment, E.PageEnd h _n) -> + ( P.lines $ + displayComment True mayComment + <> [ P.wrap $ "There's more history before the versions shown here." <> ex, + "", + dots, + "", + "⊙ " <> showNum n <> prettySCH (toSCH h) + ], [h] ) dots = "⠇" - go i sch diff = - P.lines - [ "⊙ " <> showNum i <> prettySCH sch, - "", - P.indentN 2 $ prettyDiff diff - ] + displayCausal i sch mayComment diff = + P.lines $ + displayComment False mayComment + <> [ "⊙ " <> showNum i <> prettySCH sch, + "" + ] + <> [ P.indentN 2 $ prettyDiff diff + ] ex = "Use" <> IP.makeExample IP.history ["#som3n4m3space"] @@ -2343,6 +2358,16 @@ notifyUser dir issueFn = \case <> "Please complete the" <> (P.group (P.text verb) <> ",") <> "then try again." + InvalidCommentTarget msg -> pure (P.wrap $ "Annotation failed, " <> P.text msg) + CommentedSuccessfully -> pure $ P.bold "Done." + CommentAborted -> pure (P.wrap "Annotation aborted.") + AuthorNameRequired -> + pure $ + P.hang "Please configure your a display name for your user." $ + P.lines + [ "You can do so with: ", + IP.makeExampleNoBackticks IP.configSet ["author.name", ""] + ] where iveCreatedATemporaryBranch scratchFile = P.wrap $ @@ -3474,7 +3499,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = maybe (P.red "type not found") (P.syntaxToColor . DeclPrinter.prettyDeclOrBuiltinHeader DeclPrinter.RenderUniqueTypeGuids'No (HQ'.toHQ hq)) - phq' :: _ -> Pretty = P.syntaxToColor . prettyHashQualified' + phq' :: HQ'.HashQualified Name -> Pretty = P.syntaxToColor . prettyHashQualified' numHQ' :: Input.AbsBranchId -> HQ'.HashQualified Name -> Referent -> Numbered Pretty numHQ' prefix hq r = diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 675dbc861f..4c7d31f130 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -53,6 +53,7 @@ library Unison.Codebase.Editor.HandleInput.BranchRename Unison.Codebase.Editor.HandleInput.BranchSquash Unison.Codebase.Editor.HandleInput.Cancel + Unison.Codebase.Editor.HandleInput.ConfigSet Unison.Codebase.Editor.HandleInput.DebugDefinition Unison.Codebase.Editor.HandleInput.DebugFoldRanges Unison.Codebase.Editor.HandleInput.DebugSynhashTerm @@ -67,6 +68,8 @@ library Unison.Codebase.Editor.HandleInput.FindAndReplace Unison.Codebase.Editor.HandleInput.FormatFile Unison.Codebase.Editor.HandleInput.Global + Unison.Codebase.Editor.HandleInput.History + Unison.Codebase.Editor.HandleInput.HistoryComment Unison.Codebase.Editor.HandleInput.InstallLib Unison.Codebase.Editor.HandleInput.Load Unison.Codebase.Editor.HandleInput.Ls diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal index 93ddc20c86..0726d7c56c 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack diff --git a/unison-src/transcripts/idempotent/help.md b/unison-src/transcripts/idempotent/help.md index 8355c91460..6c766f83e1 100644 --- a/unison-src/transcripts/idempotent/help.md +++ b/unison-src/transcripts/idempotent/help.md @@ -19,6 +19,11 @@ alias.type `alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`. + annotate + `annotate` Annotates the head of the current branch. + `annotate /main` Annotates the current head of the `main` + branch. + api `api` provides details about the API. @@ -94,6 +99,14 @@ Said execution will have the effect of running `!main`. + config.set + The `config.set` command sets the configuration key to the + provided value. E.g. + + `config.set author.name Author Name` + + Configuration options include: author.name + create.author `create.author alicecoder "Alice McGee"` creates `alicecoder` values in `metadata.authors` and `metadata.copyrightHolders.`