Merge pull request #2672 from unisonweb/cp/diff-namespace-hashes

Allow running namespace diffs over hashes, useful for comparing histories.
2024-11-13 09:55:35 +03:00 · 2021-11-29 23:34:02 +00:00 · 2021-11-29 23:34:02 +00:00 · 30dbfdf060
commit 30dbfdf060
parent f19cf4c3b9 224db53fac
10 changed files with 195 additions and 68 deletions
--- a/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs
+++ b/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs
@ -1,13 +1,19 @@
-{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
-module Unison.Codebase.ShortBranchHash where
+module Unison.Codebase.ShortBranchHash
+  ( toString,
+    toHash,
+    fromHash,
+    fullFromHash,
+    fromText,
+    ShortBranchHash (..),
+  )
+where

-import Unison.Prelude
-import qualified Unison.Hash as Hash
-import qualified Data.Text as Text
 import qualified Data.Set as Set
+import qualified Data.Text as Text
+import qualified Unison.Hash as Hash
+import Unison.Prelude

-newtype ShortBranchHash =
-  ShortBranchHash { toText :: Text } -- base32hex characters
+newtype ShortBranchHash = ShortBranchHash {toText :: Text} -- base32hex characters
  deriving stock (Eq, Ord, Generic)

 toString :: ShortBranchHash -> String
@ -26,9 +32,10 @@ fullFromHash = ShortBranchHash . Hash.base32Hex . coerce
 -- abc -> SBH abc
 -- #abc -> SBH abc
 fromText :: Text -> Maybe ShortBranchHash
-fromText (Text.dropWhile (=='#') -> t)
-  | Text.all (`Set.member` Hash.validBase32HexChars) t = Just
-  $ ShortBranchHash t
+fromText (Text.dropWhile (== '#') -> t)
+  | Text.all (`Set.member` Hash.validBase32HexChars) t =
+    Just $
+      ShortBranchHash t
 fromText _ = Nothing

 instance Show ShortBranchHash where
--- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
+++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
@ -550,8 +550,8 @@ loop = do
                      else
                        respondNumbered $
                          ShowDiffNamespace
-                            Path.absoluteEmpty
-                            Path.absoluteEmpty
+                            (Right Path.absoluteEmpty)
+                            (Right Path.absoluteEmpty)
                            ppe
                            outputDiff
            where
@ -694,18 +694,22 @@ loop = do
                    else
                      diffHelper (Branch.head destb) (Branch.head merged)
                        >>= respondNumbered . uncurry (ShowDiffAfterMergePreview dest0 dest)
-            DiffNamespaceI before0 after0 -> do
-              let [beforep, afterp] =
-                    resolveToAbsolute <$> [before0, after0]
-              before <- Branch.head <$> getAt beforep
-              after <- Branch.head <$> getAt afterp
-              case (Branch.isEmpty0 before, Branch.isEmpty0 after) of
-                (True, True) -> respond . NamespaceEmpty $ Right (beforep, afterp)
-                (True, False) -> respond . NamespaceEmpty $ Left beforep
-                (False, True) -> respond . NamespaceEmpty $ Left afterp
+            DiffNamespaceI before after -> unlessError do
+              let (absBefore, absAfter) = (resolveToAbsolute <$> before, resolveToAbsolute <$> after)
+              beforeBranch0 <- Branch.head <$> branchForBranchId absBefore
+              afterBranch0 <- Branch.head <$> branchForBranchId absAfter
+              lift $ case (Branch.isEmpty0 beforeBranch0, Branch.isEmpty0 afterBranch0) of
+                (True, True) -> respond . NamespaceEmpty $ (absBefore Nel.:| [absAfter])
+                (True, False) -> respond . NamespaceEmpty $ (absBefore Nel.:| [])
+                (False, True) -> respond . NamespaceEmpty $ (absAfter Nel.:| [])
                _ -> do
-                  (ppe, outputDiff) <- diffHelper before after
-                  respondNumbered $ ShowDiffNamespace beforep afterp ppe outputDiff
+                  (ppe, outputDiff) <- diffHelper beforeBranch0 afterBranch0
+                  respondNumbered $
+                    ShowDiffNamespace
+                      (resolveToAbsolute <$> before)
+                      (resolveToAbsolute <$> after)
+                      ppe
+                      outputDiff
            CreatePullRequestI baseRepo headRepo -> do
              result <- join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do
                 viewRemoteBranch headRepo \headBranch -> do
@ -3403,3 +3407,12 @@ fuzzySelectNamespace pos searchBranch0 = do
                        tShow
                        inputs
                    )
+
+-- | Get a branch from a BranchId, returning an empty one if missing, or failing with an
+-- appropriate error message if a hash cannot be found.
+branchForBranchId :: Functor m => AbsBranchId -> ExceptT (Output v) (Action' m v) (Branch m)
+branchForBranchId = \case
+  Left hash -> do
+    resolveShortBranchHash hash
+  Right path -> do
+    lift $ getAt path
--- a/unison-cli/src/Unison/Codebase/Editor/Input.hs
+++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs
@ -5,7 +5,7 @@ module Unison.Codebase.Editor.Input
  , Event(..)
  , OutputLocation(..)
  , PatchPath
-  , BranchId, parseBranchId
+  , BranchId, AbsBranchId, parseBranchId
  , HashOrHQSplit'
  , Insistence(..)
  ) where
@ -40,6 +40,7 @@ type Source = Text -- "id x = x\nconst a b = a"
 type SourceName = Text -- "foo.u" or "buffer 7"
 type PatchPath = Path.Split'
 type BranchId = Either ShortBranchHash Path'
+type AbsBranchId = Either ShortBranchHash Path.Absolute
 type HashOrHQSplit' = Either ShortHash Path.HQSplit'

 -- | Should we force the operation or not?
@ -61,7 +62,7 @@ data Input
    -- merge first causal into destination
    | MergeLocalBranchI Path' Path' Branch.MergeMode
    | PreviewMergeLocalBranchI Path' Path'
-    | DiffNamespaceI Path' Path' -- old new
+    | DiffNamespaceI BranchId BranchId -- old new
    | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode Verbosity
    | PushRemoteBranchI (Maybe WriteRemotePath) Path' PushBehavior SyncMode
    | CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace
--- a/unison-cli/src/Unison/Codebase/Editor/Output.hs
+++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs
@ -62,6 +62,7 @@ import qualified Unison.Util.Pretty as P
 import Unison.Util.Relation (Relation)
 import qualified Unison.WatchKind as WK
 import Data.Set.NonEmpty (NESet)
+import Data.List.NonEmpty (NonEmpty)

 type ListDetailed = Bool

@ -77,7 +78,7 @@ pushPull push pull p = case p of
  Pull -> pull

 data NumberedOutput v
-  = ShowDiffNamespace Path.Absolute Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
+  = ShowDiffNamespace AbsBranchId AbsBranchId PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
  | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
  | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
  | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
@ -230,7 +231,7 @@ data Output v
  | DefaultMetadataNotification
  | BadRootBranch GetRootBranchError
  | CouldntLoadBranch Branch.Hash
-  | NamespaceEmpty (Either Path.Absolute (Path.Absolute, Path.Absolute))
+  | NamespaceEmpty (NonEmpty AbsBranchId)
  | NoOp
  | -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace.
    RefusedToPush PushBehavior
--- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs
+++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs
@ -1215,12 +1215,12 @@ diffNamespace =
    )
    ( \case
        [before, after] -> first fromString $ do
-          before <- Path.parsePath' before
-          after <- Path.parsePath' after
+          before <- Input.parseBranchId before
+          after <- Input.parseBranchId after
          pure $ Input.DiffNamespaceI before after
        [before] -> first fromString $ do
-          before <- Path.parsePath' before
-          pure $ Input.DiffNamespaceI before Path.currentPath
+          before <- Input.parseBranchId before
+          pure $ Input.DiffNamespaceI before (Right Path.currentPath)
        _ -> Left $ I.help diffNamespace
    )

--- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs
+++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs
@ -124,6 +124,7 @@ import Unison.Var (Var)
 import qualified Unison.Var as Var
 import qualified Unison.WatchKind as WK
 import Prelude hiding (readFile, writeFile)
+import qualified Data.List.NonEmpty as NEList

 type Pretty = P.Pretty P.ColorText

@ -150,7 +151,7 @@ notifyNumbered o = case o of
              undoTip
            ]
      )
-      (showDiffNamespace ShowNumbers ppe e e diff)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId Path.absoluteEmpty) (absPathToBranchId Path.absoluteEmpty) diff)
  ShowDiffAfterDeleteBranch bAbs ppe diff ->
    first
      ( \p ->
@ -160,7 +161,7 @@ notifyNumbered o = case o of
              undoTip
            ]
      )
-      (showDiffNamespace ShowNumbers ppe bAbs bAbs diff)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId bAbs) (absPathToBranchId bAbs) diff)
  ShowDiffAfterModifyBranch b' _ _ (OBD.isEmpty -> True) ->
    (P.wrap $ "Nothing changed in" <> prettyPath' b' <> ".", mempty)
  ShowDiffAfterModifyBranch b' bAbs ppe diff ->
@ -174,7 +175,7 @@ notifyNumbered o = case o of
              undoTip
            ]
      )
-      (showDiffNamespace ShowNumbers ppe bAbs bAbs diff)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId bAbs) (absPathToBranchId bAbs) diff)
  ShowDiffAfterMerge _ _ _ (OBD.isEmpty -> True) ->
    (P.wrap $ "Nothing changed as a result of the merge.", mempty)
  ShowDiffAfterMerge dest' destAbs ppe diffOutput ->
@ -198,7 +199,7 @@ notifyNumbered o = case o of
                  <> " to undo the results of this merge."
            ]
      )
-      (showDiffNamespace ShowNumbers ppe destAbs destAbs diffOutput)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
  ShowDiffAfterMergePropagate dest' destAbs patchPath' ppe diffOutput ->
    first
      ( \p ->
@ -224,7 +225,7 @@ notifyNumbered o = case o of
                  <> " to undo the results of this merge."
            ]
      )
-      (showDiffNamespace ShowNumbers ppe destAbs destAbs diffOutput)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
  ShowDiffAfterMergePreview dest' destAbs ppe diffOutput ->
    first
      ( \p ->
@ -234,11 +235,11 @@ notifyNumbered o = case o of
              p
            ]
      )
-      (showDiffNamespace ShowNumbers ppe destAbs destAbs diffOutput)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
  ShowDiffAfterUndo ppe diffOutput ->
    first
      (\p -> P.lines ["Here are the changes I undid", "", p])
-      (showDiffNamespace ShowNumbers ppe e e diffOutput)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId Path.absoluteEmpty) (absPathToBranchId Path.absoluteEmpty) diffOutput)
  ShowDiffAfterPull dest' destAbs ppe diff ->
    if OBD.isEmpty diff
      then ("✅  Looks like " <> prettyPath' dest' <> " is up to date.", mempty)
@ -253,7 +254,7 @@ notifyNumbered o = case o of
                  undoTip
                ]
          )
-          (showDiffNamespace ShowNumbers ppe destAbs destAbs diff)
+          (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diff)
  ShowDiffAfterCreatePR baseRepo headRepo ppe diff ->
    if OBD.isEmpty diff
      then
@ -284,7 +285,7 @@ notifyNumbered o = case o of
                  ]
              )
          )
-          (showDiffNamespace HideNumbers ppe e e diff)
+          (showDiffNamespace HideNumbers ppe (absPathToBranchId Path.absoluteEmpty) (absPathToBranchId Path.absoluteEmpty) diff)
  -- todo: these numbers aren't going to work,
  --  since the content isn't necessarily here.
  -- Should we have a mode with no numbers? :P
@ -302,7 +303,7 @@ notifyNumbered o = case o of
                  <> P.group (prettyPath' authorPath' <> ".")
            ]
      )
-      (showDiffNamespace ShowNumbers ppe bAbs bAbs diff)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId bAbs) (absPathToBranchId bAbs) diff)
  CantDeleteDefinitions ppeDecl endangerments ->
    (P.warnCallout $
      P.lines
@ -331,7 +332,7 @@ notifyNumbered o = case o of
        ]
    , numberedArgsForEndangerments ppeDecl endangerments)
  where
-    e = Path.absoluteEmpty
+    absPathToBranchId = Right
    undoTip =
      tip $
        "You can use" <> IP.makeExample' IP.undo
@ -371,20 +372,18 @@ notifyUser dir o = case o of
        <> "when I tried to load it."
  NamespaceEmpty p ->
    case p of
-      Right (p0, p1) ->
-        pure
-          . P.warnCallout
-          $ "The namespaces "
-            <> P.string (show p0)
-            <> " and "
-            <> P.string (show p1)
-            <> " are empty. Was there a typo?"
-      Left p0 ->
+      (p0 NEList.:| []) ->
        pure
          . P.warnCallout
          $ "The namespace "
-            <> P.string (show p0)
+            <> prettyBranchId p0
            <> " is empty. Was there a typo?"
+      ps ->
+        pure
+          . P.warnCallout
+          $ "The namespaces "
+            <> P.commas (prettyBranchId <$> ps)
+            <> " are empty. Was there a typo?"
  WarnIncomingRootBranch current hashes ->
    pure $
      if null hashes
@ -1457,6 +1456,11 @@ prettyPath' p' =
    then "the current namespace"
    else P.blue (P.shown p')

+prettyBranchId :: Input.AbsBranchId -> Pretty
+prettyBranchId = \case
+  Left sbh -> prettySBH sbh
+  Right absPath -> prettyAbsolute $ absPath
+
 prettyRelative :: Path.Relative -> Pretty
 prettyRelative = P.blue . P.shown

@ -1922,8 +1926,8 @@ showDiffNamespace ::
  Var v =>
  ShowNumbers ->
  PPE.PrettyPrintEnv ->
-  Path.Absolute ->
-  Path.Absolute ->
+  Input.AbsBranchId ->
+  Input.AbsBranchId ->
  OBD.BranchDiffOutput v Ann ->
  (Pretty, NumberedArgs)
 showDiffNamespace _ _ _ _ diffOutput
@ -2173,7 +2177,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
              0 -> mempty
              c -> " (+" <> P.shown c <> " metadata)"

-    prettySummarizePatch, prettyNamePatch :: Path.Absolute -> OBD.PatchDisplay -> Numbered Pretty
+    prettySummarizePatch, prettyNamePatch :: Input.AbsBranchId -> OBD.PatchDisplay -> Numbered Pretty
    --  12. patch p (added 3 updates, deleted 1)
    prettySummarizePatch prefix (name, patchDiff) = do
      n <- numPatch prefix name
@ -2237,7 +2241,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
          pure (n, phq' hq, mempty)

    downArrow = P.bold "↓"
-    mdTypeLine :: Path.Absolute -> OBD.TypeDisplay v a -> Numbered (Pretty, Pretty)
+    mdTypeLine :: Input.AbsBranchId -> OBD.TypeDisplay v a -> Numbered (Pretty, Pretty)
    mdTypeLine p (hq, r, odecl, mddiff) = do
      n <- numHQ' p hq (Referent.Ref r)
      fmap ((n,) . P.linesNonEmpty) . sequence $
@ -2248,7 +2252,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
    -- + 2. MIT               : License
    -- - 3. AllRightsReserved : License
    mdTermLine ::
-      Path.Absolute ->
+      Input.AbsBranchId ->
      P.Width ->
      OBD.TermDisplay v a ->
      Numbered (Pretty, Pretty)
@ -2302,21 +2306,27 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
        (P.syntaxToColor . DeclPrinter.prettyDeclOrBuiltinHeader (HQ'.toHQ hq))
    phq' :: _ -> Pretty = P.syntaxToColor . prettyHashQualified'
    phq :: _ -> Pretty = P.syntaxToColor . prettyHashQualified
-    --
+
    -- DeclPrinter.prettyDeclHeader : HQ -> Either
-    numPatch :: Path.Absolute -> Name -> Numbered Pretty
+    numPatch :: Input.AbsBranchId -> Name -> Numbered Pretty
    numPatch prefix name =
-      addNumberedArg . Name.toString . Name.makeAbsolute $ Path.prefixName prefix name
+      addNumberedArg $ prefixBranchId prefix name

-    numHQ :: Path.Absolute -> HQ.HashQualified Name -> Referent -> Numbered Pretty
-    numHQ prefix hq r = addNumberedArg (HQ.toString hq')
-      where
-        hq' = HQ.requalify (fmap (Name.makeAbsolute . Path.prefixName prefix) hq) r
+    numHQ :: Input.AbsBranchId -> HQ.HashQualified Name -> Referent -> Numbered Pretty
+    numHQ prefix hq r =
+      addNumberedArg . HQ.toStringWith (prefixBranchId prefix) . HQ.requalify hq $ r

-    numHQ' :: Path.Absolute -> HQ'.HashQualified Name -> Referent -> Numbered Pretty
-    numHQ' prefix hq r = addNumberedArg (HQ'.toString hq')
-      where
-        hq' = HQ'.requalify (fmap (Name.makeAbsolute . Path.prefixName prefix) hq) r
+    numHQ' :: Input.AbsBranchId -> HQ'.HashQualified Name -> Referent -> Numbered Pretty
+    numHQ' prefix hq r =
+      addNumberedArg . HQ'.toStringWith (prefixBranchId prefix) . HQ'.requalify hq $ r
+
+    -- E.g.
+    -- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef.base.List.map"
+    -- prefixBranchId ".base" "List.map" -> ".base.List.map"
+    prefixBranchId :: Input.AbsBranchId -> Name -> String
+    prefixBranchId branchId name = case branchId of
+      Left sbh -> "#" <> SBH.toString sbh <> ":" <> Name.toString (Name.makeAbsolute  name)
+      Right pathPrefix -> Name.toString (Name.makeAbsolute . Path.prefixName pathPrefix $ name)

    addNumberedArg :: String -> Numbered Pretty
    addNumberedArg s = case sn of
--- a/unison-core/src/Unison/HashQualified'.hs
+++ b/unison-core/src/Unison/HashQualified'.hs
@ -68,6 +68,9 @@ toHash = \case
 toString :: Show n => HashQualified n -> String
 toString = Text.unpack . toText

+toStringWith :: (n -> String) -> HashQualified n -> String
+toStringWith f = Text.unpack . toTextWith (Text.pack . f)
+
 -- Parses possibly-hash-qualified into structured type.
 fromText :: Text -> Maybe (HashQualified Name)
 fromText t = case Text.breakOn "#" t of
--- a/unison-core/src/Unison/HashQualified.hs
+++ b/unison-core/src/Unison/HashQualified.hs
@ -85,6 +85,9 @@ take i = \case
 toString :: Show n => HashQualified n -> String
 toString = Text.unpack . toText

+toStringWith :: (n -> String) -> HashQualified n -> String
+toStringWith f = Text.unpack . toTextWith (Text.pack . f)
+
 fromString :: String -> Maybe (HashQualified Name)
 fromString = fromText . Text.pack

--- a/unison-src/transcripts/diff-namespace.md
+++ b/unison-src/transcripts/diff-namespace.md
@ -152,6 +152,26 @@ a = 777
 .nsw> view a b
 ```

+## Should be able to diff a namespace hash from history.
+
+```unison
+x = 1
+```
+
+```ucm
+.hashdiff> add
+```
+
+```unison
+y = 2
+```
+
+```ucm
+.hashdiff> add
+.hashdiff> history
+.hashdiff> diff.namespace #hkrqt3tm05 #is7tu6katt
+```
+
 ##

 Updates:  -- 1 to 1
--- a/unison-src/transcripts/diff-namespace.output.md
+++ b/unison-src/transcripts/diff-namespace.output.md
@ -686,6 +686,75 @@ a = 777
    use Nat +
    a#5f8uodgrtf + 1

+```
+## Should be able to diff a namespace hash from history.
+
+```unison
+x = 1
+```
+
+```ucm
+
+  I found and typechecked these definitions in scratch.u. If you
+  do an `add` or `update`, here's how your codebase would
+  change:
+  
+    ⍟ These new definitions are ok to `add`:
+    
+      x : Nat
+
+```
+```ucm
+  ☝️  The namespace .hashdiff is empty.
+
+.hashdiff> add
+
+  ⍟ I've added these definitions:
+  
+    x : Nat
+
+```
+```unison
+y = 2
+```
+
+```ucm
+
+  I found and typechecked these definitions in scratch.u. If you
+  do an `add` or `update`, here's how your codebase would
+  change:
+  
+    ⍟ These new definitions are ok to `add`:
+    
+      y : Nat
+
+```
+```ucm
+.hashdiff> add
+
+  ⍟ I've added these definitions:
+  
+    y : Nat
+
+.hashdiff> history
+
+  Note: The most recent namespace hash is immediately below this
+        message.
+  
+  ⊙ #is7tu6katt
+  
+    + Adds / updates:
+    
+      y
+  
+  □ #hkrqt3tm05 (start of history)
+
+.hashdiff> diff.namespace #hkrqt3tm05 #is7tu6katt
+
+  Added definitions:
+  
+    1. y : Nat
+
 ```
 ##