Merge pull request #5177 from unisonweb/24-07-01-todo-merge-precondition-violations

This commit is contained in:
Arya Irani 2024-07-10 13:28:59 -04:00 committed by GitHub
commit 9b11d96cbb
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
13 changed files with 852 additions and 144 deletions

View File

@ -178,6 +178,7 @@ invertDomain =
g x acc y =
Map.insert y x acc
-- | Construct a left-unique relation from a mapping from its right-elements to its left-elements.
fromRange :: (Ord a, Ord b) => Map b a -> BiMultimap a b
fromRange m =
BiMultimap (Map.foldlWithKey' f Map.empty m) m

View File

@ -139,6 +139,7 @@ import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment
import Unison.Prelude hiding (empty)
import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Util.List qualified as List
@ -148,7 +149,6 @@ import Unison.Util.Set qualified as Set
import Unison.Util.Star2 qualified as Star2
import Witherable (FilterableWithIndex (imapMaybe))
import Prelude hiding (head, read, subtract)
import qualified Unison.Reference as Reference
instance AsEmpty (Branch m) where
_Empty = prism' (const empty) matchEmpty
@ -215,7 +215,6 @@ deepTypeReferenceIds :: Branch0 m -> Set TypeReferenceId
deepTypeReferenceIds =
Set.mapMaybe Reference.toId . deepTypeReferences
namespaceStats :: Branch0 m -> NamespaceStats
namespaceStats b =
NamespaceStats

View File

@ -1,7 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
module Unison.Codebase.Causal
( Causal (currentHash, head, tail, tails),
( Causal (currentHash, valueHash, head, tail, tails),
pattern One,
pattern Cons,
pattern Merge,
@ -40,7 +40,8 @@ import Unison.Codebase.Causal.Type
currentHash,
head,
tail,
tails
tails,
valueHash
),
before,
lca,

View File

@ -9,6 +9,9 @@ module Unison.Codebase.Editor.HandleInput.Merge2
LcaMergeInfo (..),
doMerge,
doMergeLocalBranch,
-- * API exported for @todo@
hasDefnsInLib,
)
where
@ -86,6 +89,7 @@ import Unison.Merge.EitherWay (EitherWay (..))
import Unison.Merge.EitherWayI (EitherWayI (..))
import Unison.Merge.EitherWayI qualified as EitherWayI
import Unison.Merge.Libdeps qualified as Merge
import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs)
import Unison.Merge.Synhashed (Synhashed (..))
import Unison.Merge.Synhashed qualified as Synhashed
@ -139,7 +143,6 @@ import Unison.Util.SyntaxText (SyntaxText')
import Unison.Var (Var)
import Witch (unsafeFrom)
import Prelude hiding (unzip, zip, zipWith)
import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do
@ -239,11 +242,7 @@ doMerge info = do
-- Assert that neither Alice nor Bob have defns in lib
for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do
libdeps <-
case Map.lookup NameSegment.libSegment branch.children of
Nothing -> pure V2.Branch.empty
Just libdeps -> Cli.runTransaction libdeps.value
when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do
whenM (Cli.runTransaction (hasDefnsInLib branch)) do
done (Output.MergeDefnsInLib who)
-- Load Alice/Bob/LCA definitions and decl name lookups
@ -486,6 +485,17 @@ loadLibdeps branches = do
libdepsBranch <- libdepsCausal.value
pure libdepsBranch.children
------------------------------------------------------------------------------------------------------------------------
-- Merge precondition violation checks
hasDefnsInLib :: Applicative m => V2.Branch m -> m Bool
hasDefnsInLib branch = do
libdeps <-
case Map.lookup NameSegment.libSegment branch.children of
Nothing -> pure V2.Branch.empty
Just libdeps -> libdeps.value
pure (not (Map.null libdeps.terms) || not (Map.null libdeps.types))
------------------------------------------------------------------------------------------------------------------------
-- Creating Unison files

View File

@ -4,7 +4,9 @@ module Unison.Codebase.Editor.HandleInput.Todo
)
where
import Data.Either qualified as Either
import Data.Set qualified as Set
import U.Codebase.HashTags (BranchHash (..))
import U.Codebase.Sqlite.Operations qualified as Operations
import Unison.Builtin qualified as Builtin
import Unison.Cli.Monad (Cli)
@ -14,7 +16,11 @@ import Unison.Cli.PrettyPrintUtils qualified as Cli
import Unison.Codebase qualified as Codebase
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.HandleInput.Merge2 (hasDefnsInLib)
import Unison.Codebase.Editor.Output
import Unison.Hash (HashFor (..))
import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReasons (..), checkAllDeclCoherency)
import Unison.Names qualified as Names
import Unison.Prelude
import Unison.Reference (TermReference)
@ -26,11 +32,22 @@ handleTodo :: Cli ()
handleTodo = do
-- For now, we don't go through any great trouble to seek out the root of the project branch. Just assume the current
-- namespace is the root, which will be the case unless the user uses `deprecated.cd`.
currentNamespace <- Cli.getCurrentBranch0
currentCausal <- Cli.getCurrentBranch
let currentNamespace = Branch.head currentCausal
let currentNamespaceWithoutLibdeps = Branch.deleteLibdeps currentNamespace
(dependentsOfTodo, directDependencies, hashLen) <-
(defnsInLib, dependentsOfTodo, directDependencies, hashLen, incoherentDeclReasons) <-
Cli.runTransaction do
-- We call a shared `hasDefnsLib` helper even though we could easily duplicate the logic with the branch in hand
defnsInLib <- do
branch <-
currentCausal
& Branch._history
& Causal.valueHash
& coerce @_ @BranchHash
& Operations.expectBranchByBranchHash
hasDefnsInLib branch
let todoReference :: TermReference
todoReference =
Set.asSingleton (Names.refTermsNamed Builtin.names (Name.unsafeParseText "todo"))
@ -51,20 +68,28 @@ handleTodo = do
hashLen <- Codebase.hashLength
pure (dependentsOfTodo.terms, directDependencies, hashLen)
incoherentDeclReasons <-
fmap (Either.fromLeft (IncoherentDeclReasons [] [] [] [])) $
checkAllDeclCoherency
Operations.expectDeclNumConstructors
(Names.lenientToNametree (Branch.toNames currentNamespaceWithoutLibdeps))
pure (defnsInLib, dependentsOfTodo.terms, directDependencies, hashLen, incoherentDeclReasons)
ppe <- Cli.currentPrettyPrintEnvDecl
Cli.respondNumbered $
Output'Todo
TodoOutput
{ hashLen,
{ defnsInLib,
dependentsOfTodo,
directDependenciesWithoutNames =
Defns
{ terms = Set.difference directDependencies.terms (Branch.deepTermReferences currentNamespace),
types = Set.difference directDependencies.types (Branch.deepTypeReferences currentNamespace)
},
hashLen,
incoherentDeclReasons,
nameConflicts = Names.conflicts (Branch.toNames currentNamespaceWithoutLibdeps),
ppe
}

View File

@ -54,6 +54,7 @@ import Unison.Hash (Hash)
import Unison.HashQualified qualified as HQ
import Unison.HashQualified' qualified as HQ'
import Unison.LabeledDependency (LabeledDependency)
import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReasons (..))
import Unison.Name (Name)
import Unison.NameSegment (NameSegment)
import Unison.Names (Names)
@ -154,9 +155,11 @@ data NumberedOutput
(Map LabeledDependency (Set Name)) -- Mapping of external dependencies to their local dependents.
data TodoOutput = TodoOutput
{ dependentsOfTodo :: !(Set TermReferenceId),
{ defnsInLib :: !Bool,
dependentsOfTodo :: !(Set TermReferenceId),
directDependenciesWithoutNames :: !(DefnsF Set TermReference TypeReference),
hashLen :: !Int,
incoherentDeclReasons :: !IncoherentDeclReasons,
nameConflicts :: !Names,
ppe :: !PrettyPrintEnvDecl
}
@ -166,6 +169,8 @@ todoOutputIsEmpty todo =
Set.null todo.dependentsOfTodo
&& defnsAreEmpty todo.directDependenciesWithoutNames
&& Names.isEmpty todo.nameConflicts
&& not todo.defnsInLib
&& todo.incoherentDeclReasons == IncoherentDeclReasons [] [] [] []
data AmbiguousReset'Argument
= AmbiguousReset'Hash

View File

@ -87,6 +87,7 @@ import Unison.Hash32 (Hash32)
import Unison.HashQualified qualified as HQ
import Unison.HashQualified' qualified as HQ'
import Unison.LabeledDependency as LD
import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReasons (..))
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment qualified as NameSegment
@ -1401,6 +1402,7 @@ notifyUser dir = \case
<> "the same on both branches, or making neither of them a builtin, and then try the merge again."
)
]
-- Note [ConstructorAliasMessage] If you change this, also change the other similar one
MergeConstructorAlias aliceOrBob typeName conName1 conName2 ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the merge:",
@ -1416,6 +1418,7 @@ notifyUser dir = \case
"",
P.wrap "Please delete all but one name for each constructor, and then try merging again."
]
-- Note [DefnsInLibMessage] If you change this, also change the other similar one
MergeDefnsInLib aliceOrBob ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the merge:",
@ -1428,6 +1431,7 @@ notifyUser dir = \case
"",
P.wrap "Please move or remove it and then try merging again."
]
-- Note [MissingConstructorNameMessage] If you change this, also change the other similar one
MergeMissingConstructorName aliceOrBob name ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the merge:",
@ -1446,6 +1450,7 @@ notifyUser dir = \case
<> IP.makeExample IP.aliasTerm ["<hash>", prettyName name <> ".<ConstructorName>"]
<> "to give names to each unnamed constructor, and then try the merge again."
]
-- Note [NestedDeclAliasMessage] If you change this, also change the other similar one
MergeNestedDeclAlias aliceOrBob shorterName longerName ->
pure . P.wrap $
"On"
@ -1456,6 +1461,7 @@ notifyUser dir = \case
<> P.group (prettyName shorterName <> ".")
<> "I'm not able to perform a merge when a type exists nested under an alias of itself. Please separate them or"
<> "delete one copy, and then try merging again."
-- Note [StrayConstructorMessage] If you change this, also change the other similar one
MergeStrayConstructor aliceOrBob name ->
pure . P.lines $
[ P.wrap $
@ -2607,20 +2613,20 @@ unsafePrettyTermResultSig' ppe = \case
head (TypePrinter.prettySignaturesCT ppe [(r, name, typ)])
_ -> error "Don't pass Nothing"
renderNameConflicts :: PPE.PrettyPrintEnv -> Names -> Numbered Pretty
renderNameConflicts ppe conflictedNames = do
renderNameConflicts :: Int -> Names -> Numbered Pretty
renderNameConflicts hashLen conflictedNames = do
let conflictedTypeNames :: Map Name [HQ.HashQualified Name]
conflictedTypeNames =
conflictedNames
& Names.types
& R.domain
& fmap (foldMap (pure @[] . PPE.typeName ppe))
& Map.mapWithKey \name -> map (HQ.take hashLen . HQ.HashQualified name . Reference.toShortHash) . Set.toList
let conflictedTermNames :: Map Name [HQ.HashQualified Name]
conflictedTermNames =
conflictedNames
& Names.terms
& R.domain
& fmap (foldMap (pure @[] . PPE.termName ppe))
& Map.mapWithKey \name -> map (HQ.take hashLen . HQ.HashQualified name . Referent.toShortHash) . Set.toList
let allConflictedNames :: [Name]
allConflictedNames = Set.toList (Map.keysSet conflictedTermNames <> Map.keysSet conflictedTypeNames)
prettyConflictedTypes <- showConflictedNames "type" conflictedTypeNames
@ -2653,13 +2659,14 @@ renderNameConflicts ppe conflictedNames = do
prettyConflicts <- for hashes \hash -> do
n <- addNumberedArg $ SA.HashQualified hash
pure $ formatNum n <> (P.blue . P.syntaxToColor . prettyHashQualified $ hash)
pure . P.wrap $
( "The "
<> thingKind
<> " "
<> P.green (prettyName name)
<> " has conflicting definitions:"
)
pure $
P.wrap
( "The "
<> thingKind
<> " "
<> P.green (prettyName name)
<> " has conflicting definitions:"
)
<> P.newline
<> P.newline
<> P.indentN 2 (P.lines prettyConflicts)
@ -2685,11 +2692,6 @@ handleTodoOutput :: TodoOutput -> Numbered Pretty
handleTodoOutput todo
| todoOutputIsEmpty todo = pure "You have no pending todo items. Good work! ✅"
| otherwise = do
prettyConflicts <-
if todo.nameConflicts == mempty
then pure mempty
else renderNameConflicts todo.ppe.unsuffixifiedPPE todo.nameConflicts
prettyDependentsOfTodo <- do
if Set.null todo.dependentsOfTodo
then pure mempty
@ -2738,11 +2740,159 @@ handleTodoOutput todo
<> P.newline
<> P.indentN 2 (P.lines types)
prettyConflicts <-
if todo.nameConflicts == mempty
then pure mempty
else renderNameConflicts todo.hashLen todo.nameConflicts
let prettyDefnsInLib =
if todo.defnsInLib
then
P.wrap $
-- Note [DefnsInLibMessage] If you change this, also change the other similar one
"There's a type or term at the top level of the `lib` namespace, where I only expect to find"
<> "subnamespaces representing library dependencies. Please move or remove it."
else mempty
prettyConstructorAliases <-
let -- We want to filter out constructor aliases whose types are part of a "nested decl alias" problem, because
-- otherwise we'd essentially be reporting those issues twice.
--
-- That is, if we have two nested aliases like
--
-- Foo = #XYZ
-- Foo.Bar = #XYZ#0
--
-- Foo.inner.Alias = #XYZ
-- Foo.inner.Alias.Constructor = #XYZ#0
--
-- then we'd prefer to say "oh no Foo and Foo.inner.Alias are aliases" but *not* additionally say "oh no
-- Foo.Bar and Foo.inner.Alias.Constructor are aliases".
notNestedDeclAlias (typeName, _, _) =
foldr
(\(short, long) acc -> typeName /= short && typeName /= long && acc)
True
todo.incoherentDeclReasons.nestedDeclAliases
in case filter notNestedDeclAlias todo.incoherentDeclReasons.constructorAliases of
[] -> pure mempty
aliases -> do
things <-
for aliases \(typeName, conName1, conName2) -> do
n1 <- addNumberedArg (SA.Name conName1)
n2 <- addNumberedArg (SA.Name conName2)
pure (typeName, formatNum n1 <> prettyName conName1, formatNum n2 <> prettyName conName2)
pure $
things
& map
( \(typeName, prettyCon1, prettyCon2) ->
-- Note [ConstructorAliasMessage] If you change this, also change the other similar one
P.wrap ("The type" <> prettyName typeName <> "has a constructor with multiple names.")
<> P.newline
<> P.newline
<> P.indentN 2 (P.lines [prettyCon1, prettyCon2])
<> P.newline
<> P.newline
<> P.wrap "Please delete all but one name for each constructor."
)
& P.sep "\n\n"
prettyMissingConstructorNames <-
case NEList.nonEmpty todo.incoherentDeclReasons.missingConstructorNames of
Nothing -> pure mempty
Just types0 -> do
stuff <-
for types0 \typ -> do
n <- addNumberedArg (SA.Name typ)
pure (n, typ)
-- Note [MissingConstructorNameMessage] If you change this, also change the other similar one
pure $
P.wrap
"These types have some constructors with missing names."
<> P.newline
<> P.newline
<> P.indentN 2 (P.lines (fmap (\(n, typ) -> formatNum n <> prettyName typ) stuff))
<> P.newline
<> P.newline
<> P.wrap
( "You can use"
<> IP.makeExample
IP.view
[ let firstNum = fst (NEList.head stuff)
lastNum = fst (NEList.last stuff)
in if firstNum == lastNum
then P.string (show firstNum)
else P.string (show firstNum) <> "-" <> P.string (show lastNum)
]
<> "and"
<> IP.makeExample IP.aliasTerm ["<hash>", "<TypeName>.<ConstructorName>"]
<> "to give names to each unnamed constructor."
)
prettyNestedDeclAliases <-
case todo.incoherentDeclReasons.nestedDeclAliases of
[] -> pure mempty
aliases0 -> do
aliases1 <-
for aliases0 \(short, long) -> do
n1 <- addNumberedArg (SA.Name short)
n2 <- addNumberedArg (SA.Name long)
pure (formatNum n1 <> prettyName short, formatNum n2 <> prettyName long)
-- Note [NestedDeclAliasMessage] If you change this, also change the other similar one
pure $
aliases1
& map
( \(short, long) ->
P.wrap
( "These types are aliases, but one is nested under the other. Please separate them or delete"
<> "one copy."
)
<> P.newline
<> P.newline
<> P.indentN 2 (P.lines [short, long])
)
& P.sep "\n\n"
prettyStrayConstructors <-
case todo.incoherentDeclReasons.strayConstructors of
[] -> pure mempty
constructors -> do
nums <-
for constructors \constructor -> do
addNumberedArg (SA.Name constructor)
-- Note [StrayConstructorMessage] If you change this, also change the other similar one
pure $
P.wrap "These constructors are not nested beneath their corresponding type names:"
<> P.newline
<> P.newline
<> P.indentN
2
( P.lines
( zipWith
(\n constructor -> formatNum n <> prettyName constructor)
nums
constructors
)
)
<> P.newline
<> P.newline
<> P.wrap
( "For each one, please either use"
<> IP.makeExample' IP.moveAll
<> "to move if, or if it's an extra copy, you can simply"
<> IP.makeExample' IP.delete
<> "it."
)
(pure . P.sep "\n\n" . P.nonEmpty)
[ prettyDependentsOfTodo,
prettyDirectTermDependenciesWithoutNames,
prettyDirectTypeDependenciesWithoutNames,
prettyConflicts
prettyConflicts,
prettyDefnsInLib,
prettyConstructorAliases,
prettyMissingConstructorNames,
prettyNestedDeclAliases,
prettyStrayConstructors
]
listOfDefinitions ::

View File

@ -66,6 +66,7 @@ default-extensions:
- DerivingStrategies
- DerivingVia
- DoAndIfThenElse
- DuplicateRecordFields
- FlexibleContexts
- FlexibleInstances
- GADTs

View File

@ -49,12 +49,15 @@ module Unison.Names
hashQualifyTypesRelation,
hashQualifyTermsRelation,
fromTermsAndTypes,
lenientToNametree,
)
where
import Data.Map qualified as Map
import Data.Semialign (alignWith)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.These (These (..))
import Text.FuzzyFind qualified as FZF
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.ConstructorType qualified as CT
@ -64,6 +67,7 @@ import Unison.LabeledDependency (LabeledDependency)
import Unison.LabeledDependency qualified as LD
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment (NameSegment)
import Unison.Prelude
import Unison.Reference (Reference, TermReference, TypeReference)
import Unison.Reference qualified as Reference
@ -71,6 +75,10 @@ import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.ShortHash (ShortHash)
import Unison.ShortHash qualified as SH
import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF)
import Unison.Util.Nametree (Nametree, unflattenNametree)
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as R
import Unison.Util.Relation qualified as Relation
@ -95,7 +103,7 @@ instance Monoid (Names) where
mempty = Names mempty mempty
isEmpty :: Names -> Bool
isEmpty n = R.null (terms n) && R.null (types n)
isEmpty n = R.null n.terms && R.null n.types
map :: (Name -> Name) -> Names -> Names
map f (Names {terms, types}) = Names terms' types'
@ -122,8 +130,8 @@ fuzzyFind nameToText query names =
. Prelude.filter prefilter
. Map.toList
-- `mapMonotonic` is safe here and saves a log n factor
$ (Set.mapMonotonic Left <$> R.toMultimap (terms names))
<> (Set.mapMonotonic Right <$> R.toMultimap (types names))
$ (Set.mapMonotonic Left <$> R.toMultimap names.terms)
<> (Set.mapMonotonic Right <$> R.toMultimap names.types)
where
lowerqueryt = Text.toLower . Text.pack <$> query
-- For performance, case-insensitive substring matching as a pre-filter
@ -250,8 +258,8 @@ unionLeft' ::
Names
unionLeft' shouldOmit a b = Names terms' types'
where
terms' = foldl' go (terms a) (R.toList $ terms b)
types' = foldl' go (types a) (R.toList $ types b)
terms' = foldl' go a.terms (R.toList b.terms)
types' = foldl' go a.types (R.toList b.types)
go :: (Ord a, Ord b) => Relation a b -> (a, b) -> Relation a b
go acc (n, r) = if shouldOmit n r acc then acc else R.insert n r acc
@ -260,7 +268,7 @@ numHashChars :: Int
numHashChars = 3
termsNamed :: Names -> Name -> Set Referent
termsNamed = flip R.lookupDom . terms
termsNamed = flip R.lookupDom . (.terms)
-- | Get all terms with a specific name.
refTermsNamed :: Names -> Name -> Set TermReference
@ -281,13 +289,13 @@ refTermsHQNamed names = \case
in Set.mapMaybe f (termsNamed names name)
typesNamed :: Names -> Name -> Set TypeReference
typesNamed = flip R.lookupDom . types
typesNamed = flip R.lookupDom . (.types)
namesForReferent :: Names -> Referent -> Set Name
namesForReferent names r = R.lookupRan r (terms names)
namesForReferent names r = R.lookupRan r names.terms
namesForReference :: Names -> TypeReference -> Set Name
namesForReference names r = R.lookupRan r (types names)
namesForReference names r = R.lookupRan r names.types
termAliases :: Names -> Name -> Referent -> Set Name
termAliases names n r = Set.delete n $ namesForReferent names r
@ -422,20 +430,20 @@ filterTypes f (Names terms types) = Names terms (R.filterDom f types)
difference :: Names -> Names -> Names
difference a b =
Names
(R.difference (terms a) (terms b))
(R.difference (types a) (types b))
(R.difference a.terms b.terms)
(R.difference a.types b.types)
contains :: Names -> Reference -> Bool
contains names =
-- We want to compute `termsReferences` only once, if `contains` is partially applied to a `Names`, and called over
-- and over for different references. GHC would probably float `termsReferences` out without the explicit lambda, but
-- it's written like this just to be sure.
\r -> Set.member r termsReferences || R.memberRan r (types names)
\r -> Set.member r termsReferences || R.memberRan r names.types
where
-- this check makes `contains` O(n) instead of O(log n)
termsReferences :: Set TermReference
termsReferences =
Set.map Referent.toReference (R.ran (terms names))
Set.map Referent.toReference (R.ran names.terms)
-- | filters out everything from the domain except what's conflicted
conflicts :: Names -> Names
@ -448,9 +456,9 @@ conflicts Names {..} = Names (R.filterManyDom terms) (R.filterManyDom types)
-- See usage in `FileParser` for handling precendence of symbol
-- resolution where local names are preferred to codebase names.
shadowTerms :: [Name] -> Names -> Names
shadowTerms ns n0 = Names terms' (types n0)
shadowTerms ns n0 = Names terms' n0.types
where
terms' = foldl' go (terms n0) ns
terms' = foldl' go n0.terms ns
go ts name = R.deleteDom name ts
-- | Given a mapping from name to qualified name, update a `Names`,
@ -461,8 +469,8 @@ shadowTerms ns n0 = Names terms' (types n0)
importing :: [(Name, Name)] -> Names -> Names
importing shortToLongName ns =
Names
(foldl' go (terms ns) shortToLongName)
(foldl' go (types ns) shortToLongName)
(foldl' go ns.terms shortToLongName)
(foldl' go ns.types shortToLongName)
where
go :: (Ord r) => Relation Name r -> (Name, Name) -> Relation Name r
go m (shortname, qname) = case Name.searchByRankedSuffix qname m of
@ -476,8 +484,8 @@ importing shortToLongName ns =
-- `[(foo, io.foo), (bar, io.bar)]`.
expandWildcardImport :: Name -> Names -> [(Name, Name)]
expandWildcardImport prefix ns =
[(suffix, full) | Just (suffix, full) <- go <$> R.toList (terms ns)]
<> [(suffix, full) | Just (suffix, full) <- go <$> R.toList (types ns)]
[(suffix, full) | Just (suffix, full) <- go <$> R.toList ns.terms]
<> [(suffix, full) | Just (suffix, full) <- go <$> R.toList ns.types]
where
go :: (Name, a) -> Maybe (Name, Name)
go (full, _) = do
@ -498,7 +506,7 @@ constructorsForType r ns =
possibleDatas = [Referent.Con (ConstructorReference r cid) CT.Data | cid <- [0 ..]]
possibleEffects = [Referent.Con (ConstructorReference r cid) CT.Effect | cid <- [0 ..]]
trim [] = []
trim (h : t) = case R.lookupRan h (terms ns) of
trim (h : t) = case R.lookupRan h ns.terms of
s
| Set.null s -> []
| otherwise -> [(n, h) | n <- toList s] ++ trim t
@ -517,3 +525,29 @@ hashQualifyRelation fromNamedRef rel = R.map go rel
if Set.size (R.lookupDom n rel) > 1
then (HQ.take numHashChars $ fromNamedRef n r, r)
else (HQ.NameOnly n, r)
-- | "Leniently" view a Names as a NameTree
--
-- This function is "lenient" in the sense that it does not handle conflicted names with any smarts whatsoever. The
-- resulting nametree will simply contain one of the associated references of a conflicted name - we don't specify
-- which.
lenientToNametree :: Names -> Nametree (DefnsF (Map NameSegment) Referent TypeReference)
lenientToNametree names =
alignWith
( \case
This terms -> Defns {terms, types = Map.empty}
That types -> Defns {terms = Map.empty, types}
These terms types -> Defns {terms, types}
)
(lenientRelationToNametree names.terms)
(lenientRelationToNametree names.types)
where
lenientRelationToNametree :: Ord a => Relation Name a -> Nametree (Map NameSegment a)
lenientRelationToNametree =
unflattenNametree . lenientRelationToLeftUniqueRelation
lenientRelationToLeftUniqueRelation :: (Ord a, Ord b) => Relation a b -> BiMultimap b a
lenientRelationToLeftUniqueRelation =
-- The partial `Set.findMin` are fine here because Relation.domain only has non-empty Set values. A NESet would be
-- better.
BiMultimap.fromRange . Map.map Set.findMin . Relation.domain

View File

@ -72,6 +72,7 @@ library
DerivingStrategies
DerivingVia
DoAndIfThenElse
DuplicateRecordFields
FlexibleContexts
FlexibleInstances
GADTs
@ -140,6 +141,7 @@ test-suite tests
DerivingStrategies
DerivingVia
DoAndIfThenElse
DuplicateRecordFields
FlexibleContexts
FlexibleInstances
GADTs

View File

@ -83,15 +83,17 @@ module Unison.Merge.DeclCoherencyCheck
( IncoherentDeclReason (..),
checkDeclCoherency,
lenientCheckDeclCoherency,
-- * Getting all failures rather than just the first
IncoherentDeclReasons (..),
checkAllDeclCoherency,
)
where
import Control.Lens ((%=), (.=), _2)
import Control.Monad.Except (ExceptT)
import Control.Monad.Except qualified as Except
import Control.Monad.State.Strict (StateT)
import Control.Monad.State.Strict qualified as State
import Control.Monad.Trans.Except qualified as Except (except)
import Data.Functor.Compose (Compose (..))
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IntMap
@ -136,87 +138,190 @@ checkDeclCoherency ::
(TypeReferenceId -> m Int) ->
Nametree (DefnsF (Map NameSegment) Referent TypeReference) ->
m (Either IncoherentDeclReason DeclNameLookup)
checkDeclCoherency loadDeclNumConstructors =
checkDeclCoherency loadDeclNumConstructors nametree =
Except.runExceptT
. fmap (view #declNameLookup)
( checkDeclCoherencyWith
(lift . loadDeclNumConstructors)
OnIncoherentDeclReasons
{ onConstructorAlias = \x y z -> Except.throwError (IncoherentDeclReason'ConstructorAlias x y z), -- :: Name -> Name -> Name -> m (),
onMissingConstructorName = \x -> Except.throwError (IncoherentDeclReason'MissingConstructorName x), -- :: Name -> m (),
onNestedDeclAlias = \x y -> Except.throwError (IncoherentDeclReason'NestedDeclAlias x y), -- :: Name -> Name -> m (),
onStrayConstructor = \x -> Except.throwError (IncoherentDeclReason'StrayConstructor x) -- :: Name -> m ()
}
nametree
)
data IncoherentDeclReasons = IncoherentDeclReasons
{ constructorAliases :: ![(Name, Name, Name)],
missingConstructorNames :: ![Name],
nestedDeclAliases :: ![(Name, Name)],
strayConstructors :: ![Name]
}
deriving stock (Eq, Generic)
-- | Like 'checkDeclCoherency', but returns info about all of the incoherent decls found, not just the first.
checkAllDeclCoherency ::
forall m.
Monad m =>
(TypeReferenceId -> m Int) ->
Nametree (DefnsF (Map NameSegment) Referent TypeReference) ->
m (Either IncoherentDeclReasons DeclNameLookup)
checkAllDeclCoherency loadDeclNumConstructors nametree = do
State.runStateT doCheck emptyReasons <&> \(declNameLookup, reasons) ->
if reasons == emptyReasons
then Right declNameLookup
else Left (reverseReasons reasons)
where
doCheck :: StateT IncoherentDeclReasons m DeclNameLookup
doCheck =
checkDeclCoherencyWith
(lift . loadDeclNumConstructors)
( OnIncoherentDeclReasons
{ onConstructorAlias = \x y z -> #constructorAliases %= ((x, y, z) :),
onMissingConstructorName = \x -> #missingConstructorNames %= (x :),
onNestedDeclAlias = \x y -> #nestedDeclAliases %= ((x, y) :),
onStrayConstructor = \x -> #strayConstructors %= (x :)
}
)
nametree
emptyReasons :: IncoherentDeclReasons
emptyReasons =
IncoherentDeclReasons [] [] [] []
reverseReasons :: IncoherentDeclReasons -> IncoherentDeclReasons
reverseReasons reasons =
IncoherentDeclReasons
{ constructorAliases = reverse reasons.constructorAliases,
missingConstructorNames = reverse reasons.missingConstructorNames,
nestedDeclAliases = reverse reasons.nestedDeclAliases,
strayConstructors = reverse reasons.strayConstructors
}
data OnIncoherentDeclReasons m = OnIncoherentDeclReasons
{ onConstructorAlias :: Name -> Name -> Name -> m (),
onMissingConstructorName :: Name -> m (),
onNestedDeclAlias :: Name -> Name -> m (),
onStrayConstructor :: Name -> m ()
}
checkDeclCoherencyWith ::
forall m.
Monad m =>
(TypeReferenceId -> m Int) ->
OnIncoherentDeclReasons m ->
Nametree (DefnsF (Map NameSegment) Referent TypeReference) ->
m DeclNameLookup
checkDeclCoherencyWith loadDeclNumConstructors callbacks =
fmap (view #declNameLookup)
. (`State.execStateT` DeclCoherencyCheckState Map.empty (DeclNameLookup Map.empty Map.empty))
. go []
where
go ::
[NameSegment] ->
(Nametree (DefnsF (Map NameSegment) Referent TypeReference)) ->
StateT DeclCoherencyCheckState (ExceptT IncoherentDeclReason m) ()
StateT DeclCoherencyCheckState m ()
go prefix (Nametree defns children) = do
for_ (Map.toList defns.terms) \case
(_, Referent.Ref _) -> pure ()
(_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure ()
(name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do
DeclCoherencyCheckState {expectedConstructors} <- State.get
expectedConstructors1 <- lift (Except.except (Map.upsertF f typeRef expectedConstructors))
#expectedConstructors .= expectedConstructors1
where
f ::
Maybe (Name, ConstructorNames) ->
Either IncoherentDeclReason (Name, ConstructorNames)
f = \case
Nothing -> Left (IncoherentDeclReason'StrayConstructor name1)
Just (typeName, expected) ->
case recordConstructorName conId name1 expected of
Left existingName -> Left (IncoherentDeclReason'ConstructorAlias typeName existingName name1)
Right expected1 -> Right (typeName, expected1)
where
name1 = fullName name
for_ (Map.toList defns.terms) (checkDeclCoherencyWith_DoTerms callbacks prefix)
childrenWeWentInto <-
forMaybe (Map.toList defns.types) \case
(_, ReferenceBuiltin _) -> pure Nothing
(name, ReferenceDerived typeRef) -> do
DeclCoherencyCheckState {expectedConstructors} <- State.get
whatHappened <- do
let recordNewDecl ::
Maybe (Name, ConstructorNames) ->
Compose (ExceptT IncoherentDeclReason m) WhatHappened (Name, ConstructorNames)
recordNewDecl =
Compose . \case
Just (shorterTypeName, _) -> Except.throwError (IncoherentDeclReason'NestedDeclAlias shorterTypeName typeName)
Nothing ->
lift (loadDeclNumConstructors typeRef) <&> \case
0 -> UninhabitedDecl
n -> InhabitedDecl (typeName, emptyConstructorNames n)
lift (getCompose (Map.upsertF recordNewDecl typeRef expectedConstructors))
case whatHappened of
UninhabitedDecl -> do
#declNameLookup . #declToConstructors %= Map.insert typeName []
pure Nothing
InhabitedDecl expectedConstructors1 -> do
child <-
Map.lookup name children & onNothing do
Except.throwError (IncoherentDeclReason'MissingConstructorName typeName)
#expectedConstructors .= expectedConstructors1
go (name : prefix) child
DeclCoherencyCheckState {expectedConstructors} <- State.get
-- fromJust is safe here because we upserted `typeRef` key above
let (fromJust -> (_typeName, maybeConstructorNames), expectedConstructors1) =
Map.deleteLookup typeRef expectedConstructors
constructorNames <-
sequence (IntMap.elems maybeConstructorNames) & onNothing do
Except.throwError (IncoherentDeclReason'MissingConstructorName typeName)
#expectedConstructors .= expectedConstructors1
forMaybe
(Map.toList defns.types)
(checkDeclCoherencyWith_DoTypes loadDeclNumConstructors callbacks go prefix children)
let childrenWeHaventGoneInto = children `Map.withoutKeys` Set.fromList childrenWeWentInto
for_ (Map.toList childrenWeHaventGoneInto) \(name, child) -> go (name : prefix) child
checkDeclCoherencyWith_DoTerms ::
forall m.
Monad m =>
OnIncoherentDeclReasons m ->
[NameSegment] ->
(NameSegment, Referent) ->
StateT DeclCoherencyCheckState m ()
checkDeclCoherencyWith_DoTerms callbacks prefix = \case
(_, Referent.Ref _) -> pure ()
(_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure ()
(name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do
state <- State.get
whenJustM (lift (runMaybeT (Map.upsertF f typeRef state.expectedConstructors))) \expectedConstructors1 ->
#expectedConstructors .= expectedConstructors1
where
f :: Maybe (Name, ConstructorNames) -> MaybeT m (Name, ConstructorNames)
f = \case
Nothing -> do
lift (callbacks.onStrayConstructor name1)
MaybeT (pure Nothing)
Just (typeName, expected) ->
case recordConstructorName conId name1 expected of
Left existingName -> do
lift (callbacks.onConstructorAlias typeName existingName name1)
MaybeT (pure Nothing)
Right expected1 -> pure (typeName, expected1)
where
name1 =
Name.fromReverseSegments (name :| prefix)
checkDeclCoherencyWith_DoTypes ::
forall m.
Monad m =>
(TypeReferenceId -> m Int) ->
OnIncoherentDeclReasons m ->
( [NameSegment] ->
(Nametree (DefnsF (Map NameSegment) Referent TypeReference)) ->
StateT DeclCoherencyCheckState m ()
) ->
[NameSegment] ->
Map NameSegment (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) ->
(NameSegment, TypeReference) ->
StateT DeclCoherencyCheckState m (Maybe NameSegment)
checkDeclCoherencyWith_DoTypes loadDeclNumConstructors callbacks go prefix children = \case
(_, ReferenceBuiltin _) -> pure Nothing
(name, ReferenceDerived typeRef) -> do
state <- State.get
maybeWhatHappened <- do
let recordNewDecl ::
Maybe (Name, ConstructorNames) ->
Compose (MaybeT m) WhatHappened (Name, ConstructorNames)
recordNewDecl =
Compose . \case
Just (shorterTypeName, _) -> do
lift (callbacks.onNestedDeclAlias shorterTypeName typeName)
MaybeT (pure Nothing)
Nothing ->
lift (loadDeclNumConstructors typeRef) <&> \case
0 -> UninhabitedDecl
n -> InhabitedDecl (typeName, emptyConstructorNames n)
lift (runMaybeT (getCompose (Map.upsertF recordNewDecl typeRef state.expectedConstructors)))
case maybeWhatHappened of
Nothing -> pure Nothing
Just UninhabitedDecl -> do
#declNameLookup . #declToConstructors %= Map.insert typeName []
pure Nothing
Just (InhabitedDecl expectedConstructors1) -> do
case Map.lookup name children of
Nothing -> do
lift (callbacks.onMissingConstructorName typeName)
pure Nothing
Just child -> do
#expectedConstructors .= expectedConstructors1
go (name : prefix) child
state <- State.get
-- fromJust is safe here because we upserted `typeRef` key above
let (fromJust -> (_typeName, maybeConstructorNames), expectedConstructors1) =
Map.deleteLookup typeRef state.expectedConstructors
#expectedConstructors .= expectedConstructors1
case sequence (IntMap.elems maybeConstructorNames) of
Nothing -> lift (callbacks.onMissingConstructorName typeName)
Just constructorNames -> do
#declNameLookup . #constructorToDecl %= \constructorToDecl ->
List.foldl'
(\acc constructorName -> Map.insert constructorName typeName acc)
constructorToDecl
constructorNames
#declNameLookup . #declToConstructors %= Map.insert typeName constructorNames
pure (Just name)
where
typeName = fullName name
let childrenWeHaventGoneInto = children `Map.withoutKeys` Set.fromList childrenWeWentInto
for_ (Map.toList childrenWeHaventGoneInto) \(name, child) -> go (name : prefix) child
where
fullName name =
Name.fromReverseSegments (name :| prefix)
pure (Just name)
where
typeName =
Name.fromReverseSegments (name :| prefix)
-- | A lenient variant of 'checkDeclCoherency' - so lenient it can't even fail! It returns partial decl name lookup,
-- which doesn't require a name for every constructor, and allows a constructor with a nameless decl.

View File

@ -3,19 +3,15 @@
When there's nothing to do, `todo` says this:
```ucm
project/main> todo
scratch/main> todo
```
# Conflicted names
The todo command shows conflicted names (not demonstrated here yet because it is not easy to create them for tests, yet).
# Dependents of `todo`
The `todo` command shows local (outside `lib`) terms that directly call `todo`.
```ucm:hide
project/main> builtins.mergeio lib.builtins
scratch/main> builtins.mergeio lib.builtins
```
```unison
@ -27,12 +23,12 @@ bar = foo + foo
```
```ucm
project/main> add
project/main> todo
scratch/main> add
scratch/main> todo
```
```ucm:hide
project/main> delete.project project
scratch/main> delete.project scratch
```
# Direct dependencies without names
@ -41,7 +37,7 @@ The `todo` command shows hashes of direct dependencies of local (outside `lib`)
the current namespace.
```ucm:hide
project/main> builtins.mergeio lib.builtins
scratch/main> builtins.mergeio lib.builtins
```
```unison
@ -50,11 +46,143 @@ baz = foo.bar + foo.bar
```
```ucm
project/main> add
project/main> delete.namespace.force foo
project/main> todo
scratch/main> add
scratch/main> delete.namespace.force foo
scratch/main> todo
```
```ucm:hide
project/main> delete.project project
scratch/main> delete.project scratch
```
# Conflicted names
The `todo` command shows conflicted names.
```ucm:hide
scratch/main> builtins.mergeio lib.builtins
```
```unison
foo = 16
bar = 17
```
```ucm
scratch/main> add
scratch/main> debug.alias.term.force foo bar
scratch/main> todo
```
```ucm:hide
scratch/main> delete.project scratch
```
# Definitions in lib
The `todo` command complains about terms and types directly in `lib`.
```ucm:hide
scratch/main> builtins.mergeio lib.builtins
```
```unison
lib.foo = 16
```
```ucm
scratch/main> add
scratch/main> todo
```
```ucm:hide
scratch/main> delete.project scratch
```
# Constructor aliases
The `todo` command complains about constructor aliases.
```ucm:hide
scratch/main> builtins.mergeio lib.builtins
```
```unison
type Foo = One
```
```ucm
scratch/main> add
scratch/main> alias.term Foo.One Foo.Two
scratch/main> todo
```
```ucm:hide
scratch/main> delete.project scratch
```
# Missing constructor names
The `todo` command complains about missing constructor names.
```ucm:hide
scratch/main> builtins.mergeio lib.builtins
```
```unison
type Foo = Bar
```
```ucm
scratch/main> add
scratch/main> delete.term Foo.Bar
scratch/main> todo
```
```ucm:hide
scratch/main> delete.project scratch
```
# Nested decl aliases
The `todo` command complains about nested decl aliases.
```ucm:hide
scratch/main> builtins.mergeio lib.builtins
```
```unison
structural type Foo a = One a | Two a a
structural type Foo.inner.Bar a = Uno a | Dos a a
```
```ucm
scratch/main> add
scratch/main> todo
```
```ucm:hide
scratch/main> delete.project scratch
```
# Stray constructors
The `todo` command complains about stray constructors.
```ucm:hide
scratch/main> builtins.mergeio lib.builtins
```
```unison
type Foo = Bar
```
```ucm
scratch/main> add
scratch/main> alias.term Foo.Bar Baz
scratch/main> todo
```
```ucm:hide
scratch/main> delete.project scratch
```

View File

@ -3,15 +3,11 @@
When there's nothing to do, `todo` says this:
```ucm
project/main> todo
scratch/main> todo
You have no pending todo items. Good work! ✅
```
# Conflicted names
The todo command shows conflicted names (not demonstrated here yet because it is not easy to create them for tests, yet).
# Dependents of `todo`
The `todo` command shows local (outside `lib`) terms that directly call `todo`.
@ -39,14 +35,14 @@ bar = foo + foo
```
```ucm
project/main> add
scratch/main> add
⍟ I've added these definitions:
bar : Nat
foo : Nat
project/main> todo
scratch/main> todo
These terms call `todo`:
@ -78,14 +74,14 @@ baz = foo.bar + foo.bar
```
```ucm
project/main> add
scratch/main> add
⍟ I've added these definitions:
baz : Nat
foo.bar : Nat
project/main> delete.namespace.force foo
scratch/main> delete.namespace.force foo
Done.
@ -97,10 +93,261 @@ project/main> delete.namespace.force foo
Dependency Referenced In
bar 1. baz
project/main> todo
scratch/main> todo
These terms do not have any names in the current namespace:
1. #1jujb8oelv
```
# Conflicted names
The `todo` command shows conflicted names.
```unison
foo = 16
bar = 17
```
```ucm
Loading changes detected in scratch.u.
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`:
bar : Nat
foo : Nat
```
```ucm
scratch/main> add
⍟ I've added these definitions:
bar : Nat
foo : Nat
scratch/main> debug.alias.term.force foo bar
Done.
scratch/main> todo
The term bar has conflicting definitions:
1. bar#14ibahkll6
2. bar#cq22mm4sca
Tip: Use `move.term` or `delete.term` to resolve the
conflicts.
```
# Definitions in lib
The `todo` command complains about terms and types directly in `lib`.
```unison
lib.foo = 16
```
```ucm
Loading changes detected in scratch.u.
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`:
lib.foo : Nat
```
```ucm
scratch/main> add
⍟ I've added these definitions:
lib.foo : Nat
scratch/main> todo
There's a type or term at the top level of the `lib`
namespace, where I only expect to find subnamespaces
representing library dependencies. Please move or remove it.
```
# Constructor aliases
The `todo` command complains about constructor aliases.
```unison
type Foo = One
```
```ucm
Loading changes detected in scratch.u.
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`:
type Foo
```
```ucm
scratch/main> add
⍟ I've added these definitions:
type Foo
scratch/main> alias.term Foo.One Foo.Two
Done.
scratch/main> todo
The type Foo has a constructor with multiple names.
1. Foo.One
2. Foo.Two
Please delete all but one name for each constructor.
```
# Missing constructor names
The `todo` command complains about missing constructor names.
```unison
type Foo = Bar
```
```ucm
Loading changes detected in scratch.u.
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`:
type Foo
```
```ucm
scratch/main> add
⍟ I've added these definitions:
type Foo
scratch/main> delete.term Foo.Bar
Done.
scratch/main> todo
These types have some constructors with missing names.
1. Foo
You can use `view 1` and
`alias.term <hash> <TypeName>.<ConstructorName>` to give names
to each unnamed constructor.
```
# Nested decl aliases
The `todo` command complains about nested decl aliases.
```unison
structural type Foo a = One a | Two a a
structural type Foo.inner.Bar a = Uno a | Dos a a
```
```ucm
Loading changes detected in scratch.u.
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`:
structural type Foo a
structural type Foo.inner.Bar a
```
```ucm
scratch/main> add
⍟ I've added these definitions:
structural type Foo a
structural type Foo.inner.Bar a
scratch/main> todo
These types are aliases, but one is nested under the other.
Please separate them or delete one copy.
1. Foo
2. Foo.inner.Bar
```
# Stray constructors
The `todo` command complains about stray constructors.
```unison
type Foo = Bar
```
```ucm
Loading changes detected in scratch.u.
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`:
type Foo
```
```ucm
scratch/main> add
⍟ I've added these definitions:
type Foo
scratch/main> alias.term Foo.Bar Baz
Done.
scratch/main> todo
These constructors are not nested beneath their corresponding
type names:
1. Baz
For each one, please either use `move` to move if, or if it's
an extra copy, you can simply `delete` it.
```