Only return old slurp result

This commit is contained in:
Chris Penner 2022-01-17 10:46:15 -06:00
parent d33c2009a9
commit 6b5db96cde
4 changed files with 90 additions and 296 deletions

View File

@ -152,6 +152,7 @@ import Data.Set.NonEmpty (NESet)
import Unison.Symbol (Symbol)
import qualified Unison.Codebase.Editor.Input as Input
import qualified Unison.Codebase.Editor.Slurp as NewSlurp
import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult
defaultPatchNameSegment :: NameSegment
defaultPatchNameSegment = "patch"
@ -261,16 +262,11 @@ loop = do
let lexed = L.lexer (Text.unpack sourceName) (Text.unpack text)
withFile [] sourceName (text, lexed) $ \unisonFile -> do
currentNames <- currentPathNames
let sr = NewSlurp.results . NewSlurp.analyzeTypecheckedUnisonFile unisonFile
mempty
$ currentNames
let oldSlurpResult = NewSlurp.toSlurpResult unisonFile NewSlurp.UpdateOp Nothing sr
& addAliases currentNames unisonFile currentPath'
-- sr <- toSlurpResult currentPath' unisonFile <$> slurpResultNames
let sr = NewSlurp.analyzeTypecheckedUnisonFile unisonFile mempty Nothing currentNames currentPath'
names <- displayNames unisonFile
pped <- prettyPrintEnvDecl names
let ppe = PPE.suffixifiedPPE pped
respond $ Typechecked sourceName ppe oldSlurpResult unisonFile
respond $ Typechecked sourceName ppe sr unisonFile
unlessError' EvaluationFailure do
(bindings, e) <- ExceptT . eval . Evaluate ppe $ unisonFile
lift do
@ -1263,46 +1259,28 @@ loop = do
Nothing -> respond NoUnisonFile
Just uf -> do
currentNames <- currentPathNames
let sr = NewSlurp.results . NewSlurp.analyzeTypecheckedUnisonFile uf
vars
$ currentNames
-- sr <-
-- Slurp.disallowUpdates
-- . applySelection hqs uf
-- . toSlurpResult currentPath' uf
-- <$> slurpResultNames
let adds = NewSlurp.sortVars . fromMaybe mempty . Map.lookup NewSlurp.Add $ sr
let sr = NewSlurp.analyzeTypecheckedUnisonFile uf vars (Just NewSlurp.AddOp) currentNames currentPath'
let adds = SlurpResult.adds sr
stepAtNoSync Branch.CompressHistory (Path.unabsolute currentPath', doSlurpAdds adds uf)
eval . AddDefsToCodebase . NewSlurp.selectDefinitions adds $ uf
ppe <- prettyPrintEnvDecl =<< displayNames uf
let oldSlurpResult = NewSlurp.toSlurpResult uf NewSlurp.AddOp (Just vars) sr
& addAliases currentNames uf currentPath'
respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) oldSlurpResult
-- respond $ NewSlurpOutput input (PPE.suffixifiedPPE ppe) NewSlurp.AddOp sr
respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr
addDefaultMetadata adds
syncRoot
PreviewAddI names -> case (latestFile', uf) of
(Just (sourceName, _), Just uf) -> do
let vars = Set.map Name.toVar names
currentNames <- currentPathNames
let sr = NewSlurp.results . NewSlurp.analyzeTypecheckedUnisonFile uf
vars
$ currentNames
let oldSlurpResult = NewSlurp.toSlurpResult uf NewSlurp.UpdateOp (Just vars) sr
& addAliases currentNames uf currentPath'
previewResponse sourceName oldSlurpResult uf
let sr = NewSlurp.analyzeTypecheckedUnisonFile uf vars (Just NewSlurp.AddOp) currentNames currentPath'
previewResponse sourceName sr uf
_ -> respond NoUnisonFile
UpdateI maybePatchPath names -> handleUpdate input maybePatchPath names
PreviewUpdateI names -> case (latestFile', uf) of
(Just (sourceName, _), Just uf) -> do
let vars = Set.map Name.toVar names
currentNames <- currentPathNames
let sr = NewSlurp.results . NewSlurp.analyzeTypecheckedUnisonFile uf
vars
$ currentNames
let oldSlurpResult = NewSlurp.toSlurpResult uf NewSlurp.UpdateOp (Just vars) sr
& addAliases currentNames uf currentPath'
previewResponse sourceName oldSlurpResult uf
let sr = NewSlurp.analyzeTypecheckedUnisonFile uf vars (Just NewSlurp.UpdateOp) currentNames currentPath'
previewResponse sourceName sr uf
_ -> respond NoUnisonFile
TodoI patchPath branchPath' -> do
patch <- getPatchAt (fromMaybe defaultPatchPath patchPath)
@ -1840,16 +1818,7 @@ handleUpdate input maybePatchPath names = do
let patchPath = fromMaybe defaultPatchPath maybePatchPath
slurpCheckNames <- slurpResultNames
let currentPathNames = slurpCheckNames
let newSR = NewSlurp.results . NewSlurp.analyzeTypecheckedUnisonFile uf
vars
$ slurpCheckNames
let sr = NewSlurp.toSlurpResult uf NewSlurp.UpdateOp (Just vars) newSR
& addAliases slurpCheckNames uf currentPath'
-- let sr :: SlurpResult v
-- sr =
-- applySelection hqs uf
-- . toSlurpResult currentPath' uf
-- $ slurpCheckNames
let sr = NewSlurp.analyzeTypecheckedUnisonFile uf vars (Just NewSlurp.UpdateOp) slurpCheckNames currentPath'
addsAndUpdates :: SlurpComponent v
addsAndUpdates = Slurp.updates sr <> Slurp.adds sr
fileNames :: Names
@ -2770,205 +2739,6 @@ getEndangeredDependents getDependents namesToDelete rootNames = do
in NESet.nonEmptySet remainingEndangered
pure extinctToEndangered
-- Applies the selection filter to the adds/updates of a slurp result,
-- meaning that adds/updates should only contain the selection or its transitive
-- dependencies, any unselected transitive dependencies of the selection will
-- be added to `extraDefinitions`.
_applySelection ::
forall v a.
Var v =>
[HQ'.HashQualified Name] ->
UF.TypecheckedUnisonFile v a ->
SlurpResult v ->
SlurpResult v
_applySelection [] _ = id
_applySelection hqs file = \sr@SlurpResult {adds, updates} ->
sr
{ adds = adds `SC.intersection` closed,
updates = updates `SC.intersection` closed,
extraDefinitions = closed `SC.difference` selection
}
where
selectedNames =
Names.filterByHQs (Set.fromList hqs) (UF.typecheckedToNames file)
selection, closed :: SlurpComponent v
selection = SlurpComponent selectedTypes selectedTerms
closed = SC.closeWithDependencies file selection
selectedTypes, selectedTerms :: Set v
selectedTypes = Set.map var $ R.dom (Names.types selectedNames)
selectedTerms = Set.map var $ R.dom (Names.terms selectedNames)
var :: Var v => Name -> v
var name = Var.named (Name.toText name)
-- _toSlurpResult ::
-- forall v.
-- Var v =>
-- Path.Absolute ->
-- UF.TypecheckedUnisonFile v Ann ->
-- Names ->
-- SlurpResult v
-- _toSlurpResult curPath uf existingNames =
-- Slurp.subtractComponent (conflicts <> ctorCollisions) $
-- SlurpResult
-- uf
-- mempty
-- adds
-- dups
-- mempty
-- conflicts
-- updates
-- termCtorCollisions
-- ctorTermCollisions
-- termAliases
-- typeAliases
-- mempty
-- where
-- fileNames = UF.typecheckedToNames uf
-- sc :: R.Relation Name Referent -> R.Relation Name Reference -> SlurpComponent v
-- sc terms types =
-- SlurpComponent
-- { terms = Set.map var (R.dom terms),
-- types = Set.map var (R.dom types)
-- }
-- -- conflict (n,r) if n is conflicted in names0
-- conflicts :: SlurpComponent v
-- conflicts = sc terms types
-- where
-- terms =
-- R.filterDom
-- (conflicted . Names.termsNamed existingNames)
-- (Names.terms fileNames)
-- types =
-- R.filterDom
-- (conflicted . Names.typesNamed existingNames)
-- (Names.types fileNames)
-- conflicted s = Set.size s > 1
-- ctorCollisions :: SlurpComponent v
-- ctorCollisions =
-- mempty {SC.terms = termCtorCollisions <> ctorTermCollisions}
-- -- termCtorCollision (n,r) if (n, r' /= r) exists in existingNames and
-- -- r is Ref and r' is Con
-- termCtorCollisions :: Set v
-- termCtorCollisions =
-- Set.fromList
-- [ var n
-- | (n, Referent.Ref {}) <- R.toList (Names.terms fileNames),
-- [r@Referent.Con {}] <- [toList $ Names.termsNamed existingNames n],
-- -- ignore collisions w/ ctors of types being updated
-- Set.notMember (Referent.toReference r) typesToUpdate
-- ]
-- -- the set of typerefs that are being updated by this file
-- typesToUpdate :: Set Reference
-- typesToUpdate =
-- Set.fromList
-- [ r
-- | (n, r') <- R.toList (Names.types fileNames),
-- r <- toList (Names.typesNamed existingNames n),
-- r /= r'
-- ]
-- -- ctorTermCollisions (n,r) if (n, r' /= r) exists in names0 and r is Con
-- -- and r' is Ref except we relaxed it to where r' can be Con or Ref
-- -- what if (n,r) and (n,r' /= r) exists in names and r, r' are Con
-- ctorTermCollisions :: Set v
-- ctorTermCollisions =
-- Set.fromList
-- [ var n
-- | (n, Referent.Con {}) <- R.toList (Names.terms fileNames),
-- r <- toList $ Names.termsNamed existingNames n,
-- -- ignore collisions w/ ctors of types being updated
-- Set.notMember (Referent.toReference r) typesToUpdate,
-- Set.notMember (var n) (terms dups)
-- ]
-- -- duplicate (n,r) if (n,r) exists in names0
-- dups :: SlurpComponent v
-- dups = sc terms types
-- where
-- terms = R.intersection (Names.terms existingNames) (Names.terms fileNames)
-- types = R.intersection (Names.types existingNames) (Names.types fileNames)
-- -- update (n,r) if (n,r' /= r) exists in existingNames and r, r' are Ref
-- updates :: SlurpComponent v
-- updates = SlurpComponent (Set.fromList types) (Set.fromList terms)
-- where
-- terms =
-- [ var n
-- | (n, r'@Referent.Ref {}) <- R.toList (Names.terms fileNames),
-- [r@Referent.Ref {}] <- [toList $ Names.termsNamed existingNames n],
-- r' /= r
-- ]
-- types =
-- [ var n
-- | (n, r') <- R.toList (Names.types fileNames),
-- [r] <- [toList $ Names.typesNamed existingNames n],
-- r' /= r
-- ]
-- -- (n,r) is in `adds` if n isn't in existingNames
-- adds = sc terms types
-- where
-- terms = addTerms (Names.terms existingNames) (Names.terms fileNames)
-- types = addTypes (Names.types existingNames) (Names.types fileNames)
-- addTerms existingNames = R.filter go
-- where
-- go (n, Referent.Ref {}) = (not . R.memberDom n) existingNames
-- go _ = False
-- addTypes existingNames = R.filter go
-- where
-- go (n, _) = (not . R.memberDom n) existingNames
addAliases :: forall v a. (Ord v, Var v) => Names -> UF.TypecheckedUnisonFile v a -> Path.Absolute -> SlurpResult v -> SlurpResult v
addAliases existingNames uf curPath sr = sr{ termAlias=termAliases, typeAlias=typeAliases }
where
fileNames = UF.typecheckedToNames uf
buildAliases ::
R.Relation Name Referent ->
R.Relation Name Referent ->
Set v ->
Map v Slurp.Aliases
buildAliases existingNames namesFromFile dups =
Map.fromList
[ ( var n,
if null aliasesOfOld
then Slurp.AddAliases aliasesOfNew
else Slurp.UpdateAliases aliasesOfOld aliasesOfNew
)
| (n, r@Referent.Ref {}) <- R.toList namesFromFile,
-- All the refs whose names include `n`, and are not `r`
let refs = Set.delete r $ R.lookupDom n existingNames
aliasesOfNew =
Set.map (Path.unprefixName curPath) . Set.delete n $
R.lookupRan r existingNames
aliasesOfOld =
Set.map (Path.unprefixName curPath) . Set.delete n . R.dom $
R.restrictRan existingNames refs,
not (null aliasesOfNew && null aliasesOfOld),
Set.notMember (var n) dups
]
termAliases :: Map v Slurp.Aliases
termAliases =
buildAliases
(Names.terms existingNames)
(Names.terms fileNames)
(SC.terms (duplicates sr))
typeAliases :: Map v Slurp.Aliases
typeAliases =
buildAliases
(R.mapRan Referent.Ref $ Names.types existingNames)
(R.mapRan Referent.Ref $ Names.types fileNames)
(SC.types (duplicates sr))
displayI ::
Monad m =>
Names ->

View File

@ -64,7 +64,6 @@ import qualified Unison.WatchKind as WK
import Data.Set.NonEmpty (NESet)
import qualified Unison.CommandLine.InputPattern as Input
import Data.List.NonEmpty (NonEmpty)
import qualified Unison.Codebase.Editor.Slurp as NewSlurp
type ListDetailed = Bool
@ -160,7 +159,6 @@ data Output v
| ListOfPatches (Set Name)
| -- show the result of add/update
SlurpOutput Input PPE.PrettyPrintEnv (SlurpResult v)
| NewSlurpOutput Input PPE.PrettyPrintEnv NewSlurp.SlurpOp (NewSlurp.Result v)
| -- Original source, followed by the errors:
ParseErrors Text [Parser.Err v]
| TypeErrors Text PPE.PrettyPrintEnv [Context.ErrorNote v Ann]
@ -316,7 +314,6 @@ isFailure o = case o of
ListOfDefinitions _ _ ds -> null ds
ListOfPatches s -> Set.null s
SlurpOutput _ _ sr -> not $ SR.isOk sr
NewSlurpOutput _ _ _ sr -> NewSlurp.anyErrors sr
ParseErrors {} -> True
TypeErrors {} -> True
CompilerBugs {} -> True

View File

@ -1,6 +1,6 @@
module Unison.Codebase.Editor.Slurp
( SlurpOp (..),
Result,
VarsByStatus,
BlockStatus (..),
anyErrors,
results,
@ -22,8 +22,10 @@ import Debug.Pretty.Simple (pTraceShow, pTraceShowId)
import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..))
import qualified Unison.Codebase.Editor.SlurpComponent as SC
import qualified Unison.Codebase.Editor.SlurpResult as OldSlurp
import qualified Unison.Codebase.Editor.SlurpResult as SR
import Unison.Codebase.Editor.TermsAndTypes (TermedOrTyped (Termed, Typed))
import qualified Unison.Codebase.Editor.TermsAndTypes as TT
import qualified Unison.Codebase.Path as Path
import qualified Unison.DataDeclaration as DD
import qualified Unison.LabeledDependency as LD
import Unison.Name (Name)
@ -32,25 +34,17 @@ import Unison.Names (Names)
import qualified Unison.Names as Names
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import qualified Unison.Referent' as Referent
import qualified Unison.UnisonFile as UF
import qualified Unison.UnisonFile.Names as UF
import qualified Unison.Util.Relation as Rel
import qualified Unison.Util.Set as Set
import Unison.Var (Var)
import qualified Unison.Var as Var
import Unison.WatchKind (pattern TestWatch)
-- Determine which components we're considering, i.e. find the components of all provided
-- vars, then include any components they depend on.
--
-- Then, compute any deprecations and build the env
-- Then, consider all vars in each component and get status (collision, add, or update)
-- Collect and collapse the statuses of each component.
-- I.e., if any definition has an error, the whole component is an error
-- if any piece needs an update
--
--
-- Does depending on a type also mean depending on all its constructors
data SlurpOp = AddOp | UpdateOp
deriving (Eq, Show)
@ -99,26 +93,12 @@ data DefinitionNotes
| DefErr SlurpErr
deriving (Show)
type SlurpResult v = Map (TermedOrTyped v) (DefinitionNotes, Map (TermedOrTyped v) DefinitionNotes)
type SlurpAnalysis v = Map (TermedOrTyped v) (DefinitionNotes, Map (TermedOrTyped v) DefinitionNotes)
type Result v = Map (BlockStatus v) (Set (TermedOrTyped v))
-- data Result v = Result
-- { addable :: SlurpComponent v,
-- needUpdate :: SlurpComponent v,
-- duplicate :: SlurpComponent v,
-- blockedTerms :: Map (SlurpErr v) (Set v)
-- }
-- instance Semigroup (Result v) where
-- Result adds1 updates1 duplicates1 tcColl1 ctColl1 <> Result adds2 updates2 duplicates2 tcColl2 ctColl2 =
-- Result (adds1 <> adds2) (updates1 <> updates2) (duplicates1 <> duplicates2) (tcColl1 <> tcColl2) (ctColl1 <> ctColl2)
-- instance Monoid (Result v) where
-- mempty = Result mempty mempty mempty mempty mempty
type VarsByStatus v = Map (BlockStatus v) (Set (TermedOrTyped v))
-- Compute all definitions which can be added, or the reasons why a def can't be added.
results :: forall v. (Ord v, Show v) => SlurpResult v -> Result v
results :: forall v. (Ord v, Show v) => SlurpAnalysis v -> VarsByStatus v
results sr =
pTraceShowId $ analyzed
where
@ -153,9 +133,11 @@ analyzeTypecheckedUnisonFile ::
Var v =>
UF.TypecheckedUnisonFile v Ann ->
Set v ->
Maybe SlurpOp ->
Names ->
(Map (TermedOrTyped v) (DefinitionNotes, Map (TermedOrTyped v) (DefinitionNotes)))
analyzeTypecheckedUnisonFile uf defsToConsider unalteredCodebaseNames =
Path.Absolute ->
SR.SlurpResult v
analyzeTypecheckedUnisonFile uf defsToConsider slurpOp unalteredCodebaseNames currentPath =
let varRelation :: Rel.Relation (TermedOrTyped v) LD.LabeledDependency
varRelation = labelling uf
involvedVars :: Set (TermedOrTyped v)
@ -164,9 +146,15 @@ analyzeTypecheckedUnisonFile uf defsToConsider unalteredCodebaseNames =
codebaseNames = computeNamesWithDeprecations uf unalteredCodebaseNames involvedVars
varDeps :: Map (TermedOrTyped v) (Set (TermedOrTyped v))
varDeps = computeVarDeps uf involvedVars
statusMap :: Map (TermedOrTyped v) (DefinitionNotes, Map (TermedOrTyped v) DefinitionNotes)
statusMap = computeVarStatuses varDeps varRelation codebaseNames
in pTraceShowId statusMap
analysis :: SlurpAnalysis v
analysis = computeVarStatuses varDeps varRelation codebaseNames
varsByStatus :: VarsByStatus v
varsByStatus = results analysis
slurpResult :: SR.SlurpResult v
slurpResult =
toSlurpResult uf (fromMaybe UpdateOp slurpOp) defsToConsider varsByStatus
& addAliases codebaseNames currentPath
in pTraceShowId slurpResult
computeNamesWithDeprecations ::
Var v =>
@ -395,21 +383,20 @@ toSlurpResult ::
(Ord v, Show v) =>
UF.TypecheckedUnisonFile v Ann ->
SlurpOp ->
Maybe (Set v) ->
Result v ->
Set v ->
VarsByStatus v ->
OldSlurp.SlurpResult v
toSlurpResult uf op mvs r =
toSlurpResult uf op requestedVars varsByStatus =
pTraceShowId $
-- TODO: Do a proper partition to speed this up.
OldSlurp.SlurpResult
{ OldSlurp.originalFile = uf,
OldSlurp.extraDefinitions =
case mvs of
Nothing -> mempty
Just vs ->
let allVars = fold r
if Set.null requestedVars
then mempty
else
let allVars = fold varsByStatus
desired =
vs
requestedVars
& Set.flatMap (\v -> Set.fromList [Typed v, Termed v])
in sortVars $ Set.difference allVars desired,
OldSlurp.adds = adds,
@ -430,7 +417,7 @@ toSlurpResult uf op mvs r =
where
adds, duplicates, updates, termCtorColl, ctorTermColl, blocked, conflicts :: SlurpComponent v
(adds, duplicates, updates, termCtorColl, (ctorTermColl, blocked, conflicts)) =
r
varsByStatus
& ifoldMap
( \k tvs ->
let sc = sortVars $ tvs
@ -455,7 +442,7 @@ toSlurpResult uf op mvs r =
Typed v -> SlurpComponent {terms = mempty, types = Set.singleton v}
Termed v -> SlurpComponent {terms = Set.singleton v, types = mempty}
anyErrors :: Result v -> Bool
anyErrors :: VarsByStatus v -> Bool
anyErrors r =
any isError . Map.keys $ Map.filter (not . null) r
where
@ -481,3 +468,49 @@ mingleVars :: Ord v => SlurpComponent v -> Set (TermedOrTyped v)
mingleVars SlurpComponent {terms, types} =
Set.map Typed types
<> Set.map Termed terms
addAliases :: forall v. (Ord v, Var v) => Names -> Path.Absolute -> SR.SlurpResult v -> SR.SlurpResult v
addAliases existingNames curPath sr = sr {SR.termAlias = termAliases, SR.typeAlias = typeAliases}
where
fileNames = UF.typecheckedToNames $ SR.originalFile sr
buildAliases ::
Rel.Relation Name Referent ->
Rel.Relation Name Referent ->
Set v ->
Map v SR.Aliases
buildAliases existingNames namesFromFile dups =
Map.fromList
[ ( var n,
if null aliasesOfOld
then SR.AddAliases aliasesOfNew
else SR.UpdateAliases aliasesOfOld aliasesOfNew
)
| (n, r@Referent.Ref {}) <- Rel.toList namesFromFile,
-- All the refs whose names include `n`, and are not `r`
let refs = Set.delete r $ Rel.lookupDom n existingNames
aliasesOfNew =
Set.map (Path.unprefixName curPath) . Set.delete n $
Rel.lookupRan r existingNames
aliasesOfOld =
Set.map (Path.unprefixName curPath) . Set.delete n . Rel.dom $
Rel.restrictRan existingNames refs,
not (null aliasesOfNew && null aliasesOfOld),
Set.notMember (var n) dups
]
termAliases :: Map v SR.Aliases
termAliases =
buildAliases
(Names.terms existingNames)
(Names.terms fileNames)
(SC.terms (SR.duplicates sr))
typeAliases :: Map v SR.Aliases
typeAliases =
buildAliases
(Rel.mapRan Referent.Ref $ Names.types existingNames)
(Rel.mapRan Referent.Ref $ Names.types fileNames)
(SC.types (SR.duplicates sr))
var :: Var v => Name -> v
var name = Var.named (Name.toText name)

View File

@ -750,12 +750,6 @@ notifyUser dir o = case o of
Input.UpdateI {} -> True
_ -> False
in pure $ SlurpResult.pretty isPast ppe s
NewSlurpOutput input ppe slurpOp result ->
let isPast = case input of
Input.AddI {} -> True
Input.UpdateI {} -> True
_ -> False
in pure $ undefined isPast ppe slurpOp result
NoExactTypeMatches ->
pure . P.callout "☝️" $ P.wrap "I couldn't find exact type matches, resorting to fuzzy matching..."
TypeParseError src e ->