Runarorama/317 resolve edit command for resolving edit (#830)

* Fixed branchdiff semigroup
* Fixed patch diff application in 3-way merge
* Added a transcript for resolve.term

parser-typechecker/src/Unison/Codebase.hs

@@ -40,7 +40,6 @@ type EffectDeclaration v a = DD.EffectDeclaration' v a
 
 type Term v a = Term.AnnotatedTerm v a
 
-
 data Codebase m v a =
   Codebase { getTerm            :: Reference.Id -> m (Maybe (Term v a))
            , getTypeOfTermImpl  :: Reference.Id -> m (Maybe (Type v a))
@@ -74,7 +73,7 @@ data Codebase m v a =
            , termsMentioningTypeImpl :: Reference -> m (Set Referent)
            -- number of base58 characters needed to distinguish any two references in the codebase
            , hashLength         :: m Int
-           -- , refsByPrefix :: Text -> m (Set Reference)
+           , referencesByPrefix :: Text -> m (Set Reference.Id)
            }
 
 -- | Write all of the builtins types and IO types into the codebase
@@ -121,10 +120,9 @@ getTypeOfConstructor _ r cid =
 typeLookupForDependencies
   :: (Monad m, Var v, BuiltinAnnotation a)
   => Codebase m v a -> Set Reference -> m (TL.TypeLookup v a)
-typeLookupForDependencies codebase refs = foldM go mempty refs
+typeLookupForDependencies codebase = foldM go mempty
  where
---  go ::
-  go tl ref@(Reference.DerivedId id) = fmap (tl <>) $ do
+  go tl ref@(Reference.DerivedId id) = fmap (tl <>) $
     getTypeOfTerm codebase ref >>= \case
       Just typ -> pure $ TypeLookup (Map.singleton ref typ) mempty mempty
       Nothing  -> getTypeDeclaration codebase id >>= \case
@@ -192,9 +190,9 @@ makeSelfContained' code uf = do
     _ -> pure Nothing
   let
     unref :: Term v a -> Term v a
-    unref t = ABT.visitPure go t
+    unref = ABT.visitPure go
      where
-      go t@(Term.Ref' (r@(Reference.DerivedId _))) =
+      go t@(Term.Ref' r@(Reference.DerivedId _)) =
         Just (Term.var (ABT.annotation t) (refVar r))
       go _ = Nothing
     datas1 = Map.fromList
@@ -213,7 +211,7 @@ makeSelfContained' code uf = do
       (Map.fromList [ (v, (r,dd)) | (r, (v,dd)) <- Map.toList effects' ])
       (bindings ++ unrefb (UF.terms uf))
       (unrefb <$> UF.watches uf)
-  pure $ uf'
+  pure uf'
 
 getTypeOfTerm :: (Applicative m, Var v, BuiltinAnnotation a) =>
   Codebase m v a -> Reference -> m (Maybe (Type v a))

parser-typechecker/src/Unison/Codebase/Branch.hs

@@ -85,15 +85,16 @@ data BranchDiff = BranchDiff
   , addedTypes :: Star Reference NameSegment
   , removedTypes :: Star Reference NameSegment
   , changedPatches :: Map NameSegment Patch.PatchDiff
-  }
+  } deriving (Eq, Ord, Show)
 
 instance Semigroup BranchDiff where
   left <> right = BranchDiff
     { addedTerms     = addedTerms left <> addedTerms right
     , removedTerms   = removedTerms left <> removedTerms right
     , addedTypes     = addedTypes left <> addedTypes right
     , removedTypes   = removedTypes left <> removedTypes right
-    , changedPatches = changedPatches left <> changedPatches right
+    , changedPatches =
+        Map.unionWith (<>) (changedPatches left) (changedPatches right)
     }
 
 instance Monoid BranchDiff where
@@ -228,10 +229,14 @@ merge (Branch x) (Branch y) =
   apply b0 BranchDiff {..} = do
     patches <- sequenceA
       $ Map.differenceWith patchMerge (pure @m <$> _edits b0) changedPatches
+    let newPatches = makePatch <$> Map.difference changedPatches (_edits b0)
+        makePatch Patch.PatchDiff {..} =
+          let p = Patch.Patch _addedTermEdits _addedTypeEdits
+           in (H.accumulate' p, pure p)
     pure $ branch0 (Star3.difference (_terms b0) removedTerms <> addedTerms)
                    (Star3.difference (_types b0) removedTypes <> addedTypes)
                    (_children b0)
-                   patches
+                   (patches <> newPatches)
   patchMerge mhp Patch.PatchDiff {..} = Just $ do
     (_, mp) <- mhp
     p       <- mp

parser-typechecker/src/Unison/Codebase/Causal.hs

@@ -174,7 +174,7 @@ children (Merge _ _ ts    ) = Seq.fromList $ Map.elems ts
 
 threeWayMerge
   :: forall m h e d
-   . (Monad m, Hashable e, Semigroup d)
+   . (Show d, Monad m, Hashable e, Semigroup d)
   => (e -> e -> m e)
   -> (e -> e -> m d)
   -> (e -> d -> m e)

parser-typechecker/src/Unison/Codebase/Editor/Command.hs

@@ -33,6 +33,7 @@ import qualified Unison.Term                   as Term
 import qualified Unison.UnisonFile             as UF
 import qualified Unison.Lexer                  as L
 import qualified Unison.Parser                 as Parser
+import           Unison.ShortHash               ( ShortHash )
 import Unison.Type (Type)
 
 
@@ -62,6 +63,8 @@ data Command m i v a where
   -- the hash length needed to disambiguate any definition in the codebase
   CodebaseHashLength :: Command m i v Int
 
+  GetReferencesByShortHash :: ShortHash -> Command m i v (Set Reference.Id)
+
   ParseType :: Names -> LexedSource
             -> Command m i v (Either (Parser.Err v) (Type v Ann))
 
@@ -109,7 +112,7 @@ data Command m i v a where
   LoadLocalRootBranch :: Command m i v (Branch m)
 
   -- Like `LoadLocalRootBranch`.
-  LoadLocalBranch :: Branch.Hash -> Command m i v (Branch m) 
+  LoadLocalBranch :: Branch.Hash -> Command m i v (Branch m)
 
   LoadRemoteRootBranch ::
     RemoteRepo -> Command m i v (Either GitError (Branch m))

parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs

@@ -46,6 +46,7 @@ import qualified Unison.Var                    as Var
 import qualified Unison.Result as Result
 import           Unison.FileParsers             ( parseAndSynthesizeFile )
 import qualified Unison.PrettyPrintEnv         as PPE
+import qualified Unison.ShortHash              as SH
 import Unison.Type (Type)
 
 typecheck
@@ -101,7 +102,7 @@ commandLine config awaitInput setBranchRef rt notifyUser codebase =
     Evaluate ppe unisonFile        -> evalUnisonFile ppe unisonFile
     Evaluate1 ppe term             -> eval1 ppe term
     LoadLocalRootBranch        -> Codebase.getRootBranch codebase
-    LoadLocalBranch h          -> Codebase.getBranchForHash codebase h 
+    LoadLocalBranch h          -> Codebase.getBranchForHash codebase h
     SyncLocalRootBranch branch -> do
       setBranchRef branch
       Codebase.putRootBranch codebase branch
@@ -128,6 +129,8 @@ commandLine config awaitInput setBranchRef rt notifyUser codebase =
     GetTermsOfType ty -> Codebase.termsOfType codebase ty
     GetTermsMentioningType ty -> Codebase.termsMentioningType codebase ty
     CodebaseHashLength -> Codebase.hashLength codebase
+    GetReferencesByShortHash sh ->
+      Codebase.referencesByPrefix codebase (SH.toText sh)
     ParseType names (src, _) -> pure $
       Parsers.parseType (Text.unpack src) (Parser.ParsingEnv mempty names)
 

parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs

@@ -98,7 +98,7 @@ import           Unison.Util.TransitiveClosure  (transitiveClosure)
 import           Unison.Var                     ( Var )
 import qualified Unison.Var                    as Var
 import qualified Unison.Codebase.TypeEdit as TypeEdit
-import Unison.Codebase.TermEdit (TermEdit)
+import Unison.Codebase.TermEdit (TermEdit(..))
 import qualified Unison.Codebase.TermEdit as TermEdit
 import qualified Unison.Typechecker as Typechecker
 import qualified Unison.PrettyPrintEnv as PPE
@@ -195,6 +195,8 @@ loop = do
         let (p, seg) = Path.toAbsoluteSplit currentPath' s
         b <- getAt p
         eval . Eval $ Branch.getMaybePatch seg (Branch.head b)
+      getHQ'TermsIncludingHistorical p =
+        getTermsIncludingHistorical (resolveSplit' p) root0
       getHQ'Terms p = BranchUtil.getTerm (resolveSplit' p) root0
       getHQ'Types p = BranchUtil.getType (resolveSplit' p) root0
       getTypes :: Path.Split' -> Set Reference
@@ -206,7 +208,6 @@ loop = do
         let (p, seg) = Path.toAbsoluteSplit currentPath' patchPath'
         b <- getAt p
         eval . Eval $ Branch.getPatch seg (Branch.head b)
-
       withFile ambient sourceName lexed@(text, tokens) k = do
         let
           getHQ = \case
@@ -269,17 +270,18 @@ loop = do
         termNotFound = respond . TermNotFound input
         typeConflicted src = respond . TypeAmbiguous input src
         termConflicted src = respond . TermAmbiguous input src
+        hashConflicted src = respond . HashAmbiguous input src
         branchExists dest _x = respond $ BranchAlreadyExists input dest
         branchExistsSplit = branchExists . Path.unsplit'
         typeExists dest = respond . TypeAlreadyExists input dest
         termExists dest = respond . TermAlreadyExists input dest
       in case input of
       ForkLocalBranchI src0 dest0 -> do
-        let dest = Path.toAbsolutePath currentPath' $ dest0
+        let dest = Path.toAbsolutePath currentPath' dest0
         srcb <- case src0 of
           Left hash -> eval $ LoadLocalBranch hash
           Right path' -> getAt $ Path.toAbsolutePath currentPath' path'
-        if Branch.isEmpty srcb then 
+        if Branch.isEmpty srcb then
           let notfound = either (NoBranchWithHash input) (BranchNotFound input)
           in respond $ notfound src0
         else do
@@ -405,19 +407,19 @@ loop = do
           else doHistory 0 b []
         Right path' -> do
           path <- use $ currentPath . to (`Path.toAbsolutePath` path')
-          branch' <- getAt path 
+          branch' <- getAt path
           if Branch.isEmpty branch' then respond $ CreatedNewBranch path
           else doHistory 0 branch' []
         where
-          doHistory !n b acc = 
-            if maybe False (n >=) resultsCap then 
+          doHistory !n b acc =
+            if maybe False (n >=) resultsCap then
               respond $ History diffCap acc (PageEnd (Branch.headHash b) n)
             else case Branch._history b of
-              Causal.One{} -> 
+              Causal.One{} ->
                 respond $ History diffCap acc (EndOfLog $ Branch.headHash b)
-              Causal.Merge{..} -> 
-                respond $ History diffCap acc (MergeTail (Branch.headHash b) $ Map.keys tails) 
-              Causal.Cons{..} -> do 
+              Causal.Merge{..} ->
+                respond $ History diffCap acc (MergeTail (Branch.headHash b) $ Map.keys tails)
+              Causal.Cons{..} -> do
                 b' <- fmap Branch.Branch . eval . Eval $ snd tail
                 let elem = (Branch.headHash b, Branch.namesDiff b' b)
                 doHistory (n+1) b' (elem : acc)
@@ -655,17 +657,6 @@ loop = do
               makePrintNamesFromLabeled'
                 (foldMap SR'.labeledDependencies $ failed <> failedDependents)
             respond $ CantDelete input ppe failed failedDependents
---        goMany rs = do
---          let rootNames, toDelete :: Names0
---              rootNames = Branch.toNames0 root0
---              toDelete = Names.fromTerms ((name,) <$> toList rs)
---                where name = Path.toName . Path.unsplit $ resolvedPath
---          (failed, failedDependents) <- getEndangeredDependents (eval . GetDependents) toDelete rootNames
---          if failed == mempty then stepManyAt . fmap makeDelete . toList $ rs
---          else do
---            failed <- loadSearchResults $ Names.asSearchResults failed
---            failedDependents <- loadSearchResults $ Names.asSearchResults failedDependents
---            respond $ CantDelete input rootNames failed failedDependents
 
       ShowDefinitionI outputLoc (fmap HQ.unsafeFromString -> hqs) -> do
         parseNames <- makeHistoricalParsingNames $ Set.fromList hqs
@@ -845,14 +836,57 @@ loop = do
           BranchUtil.makeDeleteTypeName (resolveSplit' (HQ'.toName <$> hq))
         go r = stepManyAt . fmap makeDelete . toList . Set.delete r $ conflicted
 
-      ResolveTermNameI hq ->
-        zeroOneOrMore (getHQ'Terms hq) (termNotFound hq) go (termConflicted hq)
+      ResolveTermNameI hq -> do
+        refs <- getHQ'TermsIncludingHistorical hq
+        zeroOneOrMore refs (termNotFound hq) go (termConflicted hq)
         where
         conflicted = getHQ'Terms (fmap HQ'.toNameOnly hq)
         makeDelete =
           BranchUtil.makeDeleteTermName (resolveSplit' (HQ'.toName <$> hq))
         go r = stepManyAt . fmap makeDelete . toList . Set.delete r $ conflicted
 
+      ResolveEditI from to patchPath -> do
+        let patchPath' = fromMaybe defaultPatchPath patchPath
+        patch <- getPatchAt patchPath'
+        fromRefs <- eval $ GetReferencesByShortHash from
+        toRefs <- eval $ GetReferencesByShortHash to
+        let go :: Reference.Id
+               -> Reference.Id
+               -> Action m (Either Event Input) v ()
+            go fid tid = do
+              let fr = DerivedId fid
+                  tr = DerivedId tid
+              mft <- eval $ LoadTypeOfTerm fr
+              mtt <- eval $ LoadTypeOfTerm tr
+              ft  <- maybe (fail $ "Missing type for term " <> show fr) pure mft
+              tt  <- maybe (fail $ "Missing type for term " <> show tr) pure mtt
+              let typing | Typechecker.isEqual ft tt   = TermEdit.Same
+                         | Typechecker.isSubtype ft tt = TermEdit.Subtype
+                         | otherwise                   = TermEdit.Different
+                  -- The modified patch
+                  patch' =
+                    over Patch.termEdits
+                      (R.insert fr (Replace tr typing) . R.deleteDom fr)
+                      patch
+                  (patchPath'', patchName) = resolveSplit' patchPath'
+              -- Save the modified patch
+              _stepAtM (patchPath'', Branch.modifyPatches patchName (const patch'))
+              -- Apply the modified patch to the current path
+              -- since we might be able to propagate further.
+              void $ propagatePatch patch' currentPath'
+              -- Say something
+              success
+        zeroOneOrMore
+          fromRefs
+          (respond $ SearchTermsNotFound [HQ.HashOnly from])
+          (\r -> zeroOneOrMore toRefs
+                               (respond $ SearchTermsNotFound [HQ.HashOnly to])
+                               (go r)
+                               (hashConflicted to .
+                                 Set.map (Referent.Ref . DerivedId)))
+          (hashConflicted from .
+            Set.map (Referent.Ref . DerivedId))
+
       AddI hqs -> case uf of
         Nothing -> respond $ NoUnisonFile input
         Just uf -> do
@@ -968,7 +1002,7 @@ loop = do
 
       TodoI patchPath branchPath' -> do
         patch <- getPatchAt (fromMaybe defaultPatchPath patchPath)
-        names <- makePrintNamesFromLabeled' (Patch.labeledDependencies patch)
+        names <- makePrintNamesFromLabeled' $ Patch.labeledDependencies patch
         ppe <- prettyPrintEnv names
         branch <- getAt $ Path.toAbsolutePath currentPath' branchPath'
         let names0 = Branch.toNames0 (Branch.head branch)
@@ -1525,7 +1559,7 @@ toSlurpResult uf existingNames =
 
   -- the set of typerefs that are being updated by this file
   typesToUpdate :: Set Reference
-  typesToUpdate = Set.fromList $
+  typesToUpdate = Set.fromList
     [ r | (n,r') <- R.toList (Names.types fileNames0)
         , r <- toList (Names.typesNamed existingNames n)
         , r /= r' ]
@@ -1979,6 +2013,18 @@ makeShadowedPrintNamesFromLabeled deps shadowing = do
       shadowing
       (Names basicNames0 (fixupNamesRelative currentPath rawHistoricalNames))
 
+getTermsIncludingHistorical
+  :: Monad m => Path.HQSplit -> Branch0 m -> Action' m v (Set Referent)
+getTermsIncludingHistorical (p, hq) b = case Set.toList refs of
+  [] -> case hq of
+    HQ'.HashQualified n hs -> do
+      names <- findHistoricalHQs
+        $ Set.fromList [HQ.HashQualified (Name (NameSegment.toText n)) hs]
+      pure . R.ran $ Names.terms names
+    _ -> pure Set.empty
+  _ -> pure refs
+  where refs = BranchUtil.getTerm (p, hq) b
+
 -- discards inputs that aren't hashqualified;
 -- I'd enforce it with finer-grained types if we had them.
 findHistoricalHQs :: Monad m => Set HQ.HashQualified -> Action' m v Names0
@@ -2015,11 +2061,14 @@ makeShadowedPrintNamesFromHQ lexedHQs shadowing = do
       shadowing
       (Names basicNames0 (fixupNamesRelative currentPath rawHistoricalNames))
 
-makePrintNamesFromLabeled' :: Monad m => Set LabeledDependency -> Action' m v Names
+makePrintNamesFromLabeled'
+  :: Monad m => Set LabeledDependency -> Action' m v Names
 makePrintNamesFromLabeled' deps = do
-  root <- use root
-  currentPath <- use currentPath
-  (_missing, rawHistoricalNames) <- eval . Eval $ Branch.findHistoricalRefs deps root
+  root                           <- use root
+  currentPath                    <- use currentPath
+  (_missing, rawHistoricalNames) <- eval . Eval $ Branch.findHistoricalRefs
+    deps
+    root
   basicNames0 <- basicPrettyPrintNames0
   pure $ Names basicNames0 (fixupNamesRelative currentPath rawHistoricalNames)
 

parser-typechecker/src/Unison/Codebase/Editor/Input.hs

@@ -16,8 +16,9 @@ import qualified Unison.Codebase.Path          as Path
 import           Unison.Codebase.Editor.RemoteRepo
 import           Unison.Reference (Reference)
 import qualified Unison.Hash as Hash
+import           Unison.ShortHash (ShortHash)
 import qualified Unison.Codebase.Causal as Causal
-import qualified Data.Text as Text 
+import qualified Data.Text as Text
 
 data Event
   = UnisonFileChanged SourceName Source
@@ -87,10 +88,11 @@ data Input
     | AddTypeReplacementI PatchPath Reference Reference
     | RemoveTermReplacementI PatchPath Reference Reference
     | RemoveTypeReplacementI PatchPath Reference Reference
+    | ResolveEditI ShortHash ShortHash (Maybe PatchPath)
   | UndoI
   -- 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 
+  | HistoryI (Maybe Int) (Maybe Int) BranchId
   -- execute an IO thunk
   | ExecuteI String
   | TestI Bool Bool -- TestI showSuccesses showFailures