mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-19 06:17:33 +03:00
Merge pull request #4502 from unisonweb/travis/tdnr-bug
This commit is contained in:
commit
37ca00c65e
@ -32,8 +32,10 @@ import Control.Monad.State
|
||||
modify,
|
||||
)
|
||||
import Control.Monad.Writer
|
||||
import Data.Foldable
|
||||
import Data.Map qualified as Map
|
||||
import Data.Sequence.NonEmpty qualified as NESeq (toSeq)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.Blank qualified as B
|
||||
@ -229,17 +231,15 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
|
||||
case catMaybes resolutions of
|
||||
[] -> pure oldType
|
||||
rs ->
|
||||
let goAgain =
|
||||
any ((== 1) . length . dedupe . filter Context.isExact . suggestions) rs
|
||||
in if goAgain
|
||||
then do
|
||||
traverse_ substSuggestion rs
|
||||
synthesizeAndResolve ppe tdnrEnv
|
||||
else do
|
||||
-- The type hasn't changed
|
||||
liftResult $ suggest rs
|
||||
pure oldType
|
||||
applySuggestions rs >>= \case
|
||||
True -> do
|
||||
synthesizeAndResolve ppe tdnrEnv
|
||||
False -> do
|
||||
-- The type hasn't changed
|
||||
liftResult $ suggest rs
|
||||
pure oldType
|
||||
where
|
||||
|
||||
addTypedComponent :: Context.InfoNote v loc -> State (Env v loc) ()
|
||||
addTypedComponent (Context.TopLevelComponent vtts) =
|
||||
for_ vtts $ \(v, typ, _) ->
|
||||
@ -268,23 +268,50 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
|
||||
Var.MissingResult -> v
|
||||
_ -> Var.named name
|
||||
|
||||
substSuggestion :: Resolution v loc -> TDNR f v loc ()
|
||||
extractSubstitution :: [Context.Suggestion v loc] -> Maybe (Either v Referent)
|
||||
extractSubstitution suggestions =
|
||||
let groupedByName :: [([Name.Name], Either v Referent)] =
|
||||
map (\(a, b) -> (b, a))
|
||||
. Map.toList
|
||||
. fmap Set.toList
|
||||
. foldl'
|
||||
( \b Context.Suggestion {suggestionName, suggestionReplacement} ->
|
||||
Map.insertWith
|
||||
Set.union
|
||||
suggestionReplacement
|
||||
(Set.singleton (Name.unsafeFromText suggestionName))
|
||||
b
|
||||
)
|
||||
Map.empty
|
||||
$ filter Context.isExact suggestions
|
||||
matches :: Set (Either v Referent) = Name.preferShallowLibDepth groupedByName
|
||||
in case toList matches of
|
||||
[x] -> Just x
|
||||
_ -> Nothing
|
||||
|
||||
applySuggestions :: [Resolution v loc] -> TDNR f v loc Bool
|
||||
applySuggestions = foldlM phi False
|
||||
where
|
||||
phi b a = do
|
||||
didSub <- substSuggestion a
|
||||
pure $! b || didSub
|
||||
|
||||
substSuggestion :: Resolution v loc -> TDNR f v loc Bool
|
||||
substSuggestion
|
||||
( Resolution
|
||||
name
|
||||
_
|
||||
loc
|
||||
v
|
||||
( filter Context.isExact ->
|
||||
[Context.Suggestion _ _ replacement Context.Exact]
|
||||
)
|
||||
(extractSubstitution -> Just replacement)
|
||||
) =
|
||||
do
|
||||
modify (substBlank (Text.unpack name) loc solved)
|
||||
lift . btw $ Context.Decision (suggestedVar v name) loc solved
|
||||
pure True
|
||||
where
|
||||
solved = either (Term.var loc) (Term.fromReferent loc) replacement
|
||||
substSuggestion _ = pure ()
|
||||
substSuggestion _ = pure False
|
||||
|
||||
-- Resolve a `Blank` to a term
|
||||
substBlank :: String -> loc -> Term v loc -> Term v loc -> Term v loc
|
||||
|
@ -35,16 +35,17 @@ module Unison.Name
|
||||
unqualified,
|
||||
|
||||
-- * To organize later
|
||||
libSegment,
|
||||
sortNames,
|
||||
sortNamed,
|
||||
sortByText,
|
||||
searchBySuffix,
|
||||
searchByRankedSuffix,
|
||||
suffixFrom,
|
||||
shortestUniqueSuffix,
|
||||
commonPrefix,
|
||||
libSegment,
|
||||
preferShallowLibDepth,
|
||||
searchByRankedSuffix,
|
||||
searchBySuffix,
|
||||
shortestUniqueSuffix,
|
||||
sortByText,
|
||||
sortNamed,
|
||||
sortNames,
|
||||
splits,
|
||||
suffixFrom,
|
||||
|
||||
-- * Re-exports
|
||||
module Unison.Util.Alphabetical,
|
||||
@ -333,23 +334,30 @@ searchBySuffix suffix rel =
|
||||
-- Example: foo.bar shadows lib.foo.bar
|
||||
-- Example: lib.foo.bar shadows lib.blah.lib.foo.bar
|
||||
searchByRankedSuffix :: (Ord r) => Name -> R.Relation Name r -> Set r
|
||||
searchByRankedSuffix suffix rel = case searchBySuffix suffix rel of
|
||||
rs | Set.size rs <= 1 -> rs
|
||||
rs -> case Map.lookup 0 byDepth <|> Map.lookup 1 byDepth of
|
||||
-- anything with more than one lib in it is treated the same
|
||||
Nothing -> rs
|
||||
Just rs -> Set.fromList rs
|
||||
where
|
||||
byDepth =
|
||||
List.multimap
|
||||
[ (minLibs ns, r)
|
||||
| r <- toList rs,
|
||||
ns <- [filter ok (toList (R.lookupRan r rel))]
|
||||
]
|
||||
searchByRankedSuffix suffix rel =
|
||||
let rs = searchBySuffix suffix rel
|
||||
in case Set.size rs <= 1 of
|
||||
True -> rs
|
||||
False ->
|
||||
let ok name = compareSuffix suffix name == EQ
|
||||
withNames = map (\r -> (filter ok (toList (R.lookupRan r rel)), r)) (toList rs)
|
||||
in preferShallowLibDepth withNames
|
||||
|
||||
-- | precondition: input list is deduped, and so is the Name list in
|
||||
-- the tuple
|
||||
preferShallowLibDepth :: Ord r => [([Name], r)] -> Set r
|
||||
preferShallowLibDepth = \case
|
||||
[] -> Set.empty
|
||||
[x] -> Set.singleton (snd x)
|
||||
rs ->
|
||||
let
|
||||
byDepth = List.multimap (map (first minLibs) rs)
|
||||
libCount = length . filter (== libSegment) . toList . reverseSegments
|
||||
minLibs [] = 0
|
||||
minLibs ns = minimum (map libCount ns)
|
||||
ok name = compareSuffix suffix name == EQ
|
||||
in case Map.lookup 0 byDepth <|> Map.lookup 1 byDepth of
|
||||
Nothing -> Set.fromList (map snd rs)
|
||||
Just rs -> Set.fromList rs
|
||||
|
||||
libSegment :: NameSegment
|
||||
libSegment = NameSegment "lib"
|
||||
|
16
unison-src/transcripts/fix4498.md
Normal file
16
unison-src/transcripts/fix4498.md
Normal file
@ -0,0 +1,16 @@
|
||||
```ucm:hide
|
||||
.> builtins.merge
|
||||
```
|
||||
|
||||
```unison
|
||||
lib.dep0.bonk.foo = 5
|
||||
lib.dep0.zonk.foo = "hi"
|
||||
lib.dep0.lib.dep1.foo = 6
|
||||
myterm = foo + 2
|
||||
```
|
||||
|
||||
```ucm
|
||||
.> add
|
||||
.> view myterm
|
||||
```
|
||||
|
39
unison-src/transcripts/fix4498.output.md
Normal file
39
unison-src/transcripts/fix4498.output.md
Normal file
@ -0,0 +1,39 @@
|
||||
```unison
|
||||
lib.dep0.bonk.foo = 5
|
||||
lib.dep0.zonk.foo = "hi"
|
||||
lib.dep0.lib.dep1.foo = 6
|
||||
myterm = foo + 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`:
|
||||
|
||||
lib.dep0.bonk.foo : Nat
|
||||
lib.dep0.lib.dep1.foo : Nat
|
||||
lib.dep0.zonk.foo : Text
|
||||
myterm : Nat
|
||||
|
||||
```
|
||||
```ucm
|
||||
.> add
|
||||
|
||||
⍟ I've added these definitions:
|
||||
|
||||
lib.dep0.bonk.foo : Nat
|
||||
lib.dep0.lib.dep1.foo : Nat
|
||||
lib.dep0.zonk.foo : Text
|
||||
myterm : Nat
|
||||
|
||||
.> view myterm
|
||||
|
||||
myterm : Nat
|
||||
myterm =
|
||||
use Nat +
|
||||
bonk.foo + 2
|
||||
|
||||
```
|
Loading…
Reference in New Issue
Block a user