From 6f9bda9528b794ba806da200f440c4fbc1537d9c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 16 Aug 2024 12:03:18 -0700 Subject: [PATCH 1/8] Improve error LSP ranges on type mismatches --- parser-typechecker/src/Unison/PrintError.hs | 2 +- unison-cli/src/Unison/LSP/FileAnalysis.hs | 40 ++++++++++++++++++++- unison-core/src/Unison/Term.hs | 18 +++++----- 3 files changed, 49 insertions(+), 11 deletions(-) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index d39e152903..74273f12cb 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -369,7 +369,7 @@ renderTypeError e env src = case e of Mismatch {..} -> mconcat [ Pr.lines - [ "I found a value of type: " <> style Type1 (renderType' env foundLeaf), + [ "I found a value of type: " <> style Type1 (renderType' env foundLeaf), "where I expected to find: " <> style Type2 (renderType' env expectedLeaf) ], "\n\n", diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index 2b5363c7ff..e624de7d51 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -216,7 +216,10 @@ analyseNotes fileUri ppe src notes = do Result.TypeError errNote@(Context.ErrorNote {cause}) -> do let typeErr = TypeError.typeErrorFromNote errNote ranges = case typeErr of - TypeError.Mismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite + TypeError.Mismatch {mismatchSite} -> do + let locs = ABT.annotation <$> expressionLeafNodes mismatchSite + (r, rs) <- withNeighbours (locs >>= aToR) + pure (r, ("mismatch",) <$> rs) TypeError.BooleanMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite TypeError.ExistentialMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite TypeError.FunctionApplication {f} -> singleRange $ ABT.annotation f @@ -471,3 +474,38 @@ mkTypeSignatureHints parsedFile typecheckedFile = do pure $ TypeSignatureHint name (Referent.fromTermReferenceId ref) newRange typ ) in typeHints + +-- | Crawl a term and find the nodes which actually influence its return type. This is useful for narrowing down a giant +-- "This let/do block has the wrong type" into "This specific line returns the wrong type" +-- This is just a heuristic. +expressionLeafNodes :: Term.Term2 vt at ap v a -> [Term.Term2 vt at ap v a] +expressionLeafNodes abt = + case ABT.out abt of + ABT.Var {} -> [abt] + ABT.Cycle r -> expressionLeafNodes r + ABT.Abs _ r -> expressionLeafNodes r + ABT.Tm f -> case f of + Term.Int {} -> [abt] + Term.Nat {} -> [abt] + Term.Float {} -> [abt] + Term.Boolean {} -> [abt] + Term.Text {} -> [abt] + Term.Char {} -> [abt] + Term.Blank {} -> [abt] + Term.Ref {} -> [abt] + Term.Constructor {} -> [abt] + Term.Request {} -> [abt] + -- Not 100% sure whether the error should appear on the handler or action, maybe both? + Term.Handle handler _action -> expressionLeafNodes handler + Term.App _a _b -> [abt] + Term.Ann a _ -> expressionLeafNodes a + Term.List {} -> [abt] + Term.If _cond a b -> expressionLeafNodes a <> expressionLeafNodes b + Term.And {} -> [abt] + Term.Or {} -> [abt] + Term.Lam a -> expressionLeafNodes a + Term.LetRec _isTop _bindings body -> expressionLeafNodes body + Term.Let _isTop _bindings body -> expressionLeafNodes body + Term.Match _a cases -> cases & foldMap \(Term.MatchCase {matchBody}) -> expressionLeafNodes matchBody + Term.TermLink {} -> [abt] + Term.TypeLink {} -> [abt] diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index d3608bc426..1dc019e5a6 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -72,21 +72,21 @@ data F typeVar typeAnn patternAnn a | Ref Reference | Constructor ConstructorReference | Request ConstructorReference - | Handle a a - | App a a + | Handle a {- <- the handler -} a {- <- the action to run -} + | App a {- <- func -} a {- <- arg -} | Ann a (Type typeVar typeAnn) | List (Seq a) - | If a a a + | If a {- <- cond -} a {- <- then -} a {- <- else -} | And a a | Or a a | Lam a | -- Note: let rec blocks have an outer ABT.Cycle which introduces as many -- variables as there are bindings - LetRec IsTop [a] a - | -- Note: first parameter is the binding, second is the expression which may refer - -- to this let bound variable. Constructed as `Let b (abs v e)` - Let IsTop a a - | -- Pattern matching / eliminating data types, example: + LetRec IsTop [a {- <- bindings -}] a {- <- body -} + -- Note: first parameter is the binding, second is the expression which may refer + | -- to this let bound variable. Constructed as `Let b (abs v e)` + Let IsTop a {- <- binding -} a {- <- body -} + -- Pattern matching / eliminating data types, example: -- case x of -- Just n -> rhs1 -- Nothing -> rhs2 @@ -94,7 +94,7 @@ data F typeVar typeAnn patternAnn a -- translates to -- -- Match x - -- [ (Constructor 0 [Var], ABT.abs n rhs1) + | -- [ (Constructor 0 [Var], ABT.abs n rhs1) -- , (Constructor 1 [], rhs2) ] Match a [MatchCase patternAnn a] | TermLink Referent From 31904863aa223ee0e29c4278f4a720620b43e4c6 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 16 Aug 2024 12:52:54 -0700 Subject: [PATCH 2/8] Rewrite test helpers to support multiple diagnostic ranges --- unison-cli/tests/Unison/Test/LSP.hs | 118 ++++++++++++++++++++-------- 1 file changed, 86 insertions(+), 32 deletions(-) diff --git a/unison-cli/tests/Unison/Test/LSP.hs b/unison-cli/tests/Unison/Test/LSP.hs index 4459d93204..3981e8131e 100644 --- a/unison-cli/tests/Unison/Test/LSP.hs +++ b/unison-cli/tests/Unison/Test/LSP.hs @@ -49,7 +49,8 @@ test = do ] scope "diagnostics" $ tests - [ unusedBindingLocations + [ unusedBindingLocations, + typeMismatchLocations ] trm :: Term.F Symbol () () (ABT.Term (Term.F Symbol () ()) Symbol ()) -> LSPQ.SourceNode () @@ -251,35 +252,44 @@ term = let extractCursor :: Text -> Test (Lexer.Pos, Text) extractCursor txt = case splitOnDelimiter '^' txt of - Nothing -> crash "expected exactly one cursor" Just (before, pos, after) -> pure (pos, before <> after) + _ -> crash "expected exactly one cursor" -- | Splits a text on a delimiter, returning the text before and after the delimiter, along with the position of the delimiter. -- -- >>> splitOnDelimiter '^' "foo b^ar baz" --- Just ("foo b",Pos {line = 0, column = 5},"ar baz") +-- Just ("foo b",Pos {line = 1, column = 5},"ar baz") splitOnDelimiter :: Char -> Text -> Maybe (Text, Lexer.Pos, Text) splitOnDelimiter sym txt = - case Text.splitOn (Text.singleton sym) txt of - [before, after] -> - let col = (Text.length $ Text.takeWhileEnd (/= '\n') before) + 1 + case second Text.uncons $ Text.breakOn (Text.singleton sym) txt of + (_before, Nothing) -> Nothing + (before, Just (_delim, after)) -> + let col = (Text.length $ Text.takeWhileEnd (/= '\n') before) line = Text.count "\n" before + 1 - in Just $ (before, Lexer.Pos line col, after) - _ -> Nothing + in Just (before, Lexer.Pos line col, after) --- | Test helper which lets you specify a cursor position inline with source text as a '^'. +-- | Test helper which lets you specify a relevant block of source inline using specified delimiters +-- +-- >>> extractDelimitedBlocks ('{', '}') "foo {bar} baz" +-- Just ("foo bar baz",[(Ann {start = Pos {line = 1, column = 5}, end = Pos {line = 1, column = 8}},"bar")]) -- --- >>> extractDelimitedBlock ('{', '}') "foo {bar} baz" --- Just (Ann {start = Pos {line = 1, column = 4}, end = Pos {line = 1, column = 7}},"bar","foo bar baz") +-- >>> extractDelimitedBlocks ('{', '}') "term =\n {foo} = 12345" +-- Just ("term =\n foo = 12345",[(Ann {start = Pos {line = 2, column = 3}, end = Pos {line = 2, column = 6}},"foo")]) -- --- >>> extractDelimitedBlock ('{', '}') "term =\n {foo} = 12345" --- Just (Ann {start = Pos {line = 2, column = 2}, end = Pos {line = 2, column = 5}},"foo","term =\n foo = 12345") -extractDelimitedBlock :: (Char, Char) -> Text -> Maybe (Ann {- ann spanning the inside of the delimiters -}, Text {- Text within the delimiters -}, Text {- entire source text with the delimiters stripped -}) -extractDelimitedBlock (startDelim, endDelim) txt = do - (beforeStart, startPos, afterStart) <- splitOnDelimiter startDelim txt - (beforeEnd, endPos, afterEnd) <- splitOnDelimiter endDelim (beforeStart <> afterStart) - let ann = Ann startPos endPos - pure (ann, Text.takeWhile (/= endDelim) afterStart, beforeEnd <> afterEnd) +-- >>> extractDelimitedBlocks ('{', '}') "term =\n {foo} = {12345} + 10" +-- Just ("term =\n foo = 12345 + 10",[(Ann {start = Pos {line = 2, column = 3}, end = Pos {line = 2, column = 6}},"foo"),(Ann {start = Pos {line = 3, column = 4}, end = Pos {line = 3, column = 9}},"12345")]) +extractDelimitedBlocks :: (Char, Char) -> Text -> Maybe (Text {- entire source text with the delimiters stripped -}, [(Ann {- ann spanning the inside of the delimiters -}, Text {- Text within the delimiters -})]) +extractDelimitedBlocks (startDelim, endDelim) txt = + extractDelimitedBlocksHelper mempty txt + where + extractDelimitedBlocksHelper :: Lexer.Pos -> Text -> Maybe (Text, [(Ann, Text)]) + extractDelimitedBlocksHelper offset txt = do + (beforeStart, startPos, afterStart) <- splitOnDelimiter startDelim txt + (beforeEnd, endPos, afterEnd) <- splitOnDelimiter endDelim (beforeStart <> afterStart) + let ann = Ann (offset <> startPos) (offset <> endPos) + case extractDelimitedBlocksHelper endPos afterEnd of + Nothing -> pure (beforeEnd <> afterEnd, [(ann, Text.takeWhile (/= endDelim) afterStart)]) + Just (cleanSrc, splits) -> pure $ (beforeEnd <> cleanSrc, (ann, Text.takeWhile (/= endDelim) afterStart) : splits) makeNodeSelectionTest :: (String, Text, Bool, LSPQ.SourceNode ()) -> Test () makeNodeSelectionTest (name, testSrc, testTypechecked, expected) = scope name $ do @@ -418,25 +428,39 @@ withTestCodebase action = do makeDiagnosticRangeTest :: (String, Text) -> Test () makeDiagnosticRangeTest (testName, testSrc) = scope testName $ do - let (cleanSrc, mayExpectedDiagnostic) = case extractDelimitedBlock ('«', '»') testSrc of - Nothing -> (testSrc, Nothing) - Just (ann, block, clean) -> (clean, Just (ann, block)) + (cleanSrc, ranges) <- case extractDelimitedBlocks ('«', '»') testSrc of + Nothing -> pure (testSrc, []) + Just (cleanSrc, ranges) -> pure (cleanSrc, ranges) (pf, _mayTypecheckedFile) <- typecheckSrc testName cleanSrc UF.terms pf & Map.elems & \case [(_a, trm)] -> do - case (mayExpectedDiagnostic, UnusedBindings.analyseTerm (LSP.Uri "test") trm) of - (Just (ann, _block), [diag]) -> do - let expectedRange = Cv.annToRange ann - let actualRange = Just (diag ^. LSP.range) - when (expectedRange /= actualRange) do - crash $ "Expected diagnostic at range: " <> show expectedRange <> ", got: " <> show actualRange - (Nothing, []) -> pure () - (expected, actual) -> case expected of - Nothing -> crash $ "Expected no diagnostics, got: " <> show actual - Just _ -> crash $ "Expected exactly one diagnostic, but got " <> show actual + let diags = UnusedBindings.analyseTerm (LSP.Uri "test") trm + matchDiagnostics ranges diags _ -> crash "Expected exactly one term" + where + matchDiagnostics :: [(Ann, Text)] -> [LSP.Diagnostic] -> Test () + matchDiagnostics ranges diags = case (ranges, diags) of + ([], []) -> pure () + ([], _ : _) -> crash $ "Got diagnostics that weren't matched: " <> show diags + (_ : _, []) -> crash $ "Expected diagnostics that weren't provided" <> show ranges + (range@(ann, _src) : rest, diags) -> + diags + & popFind + ( \diag -> + let expectedRange = Cv.annToRange ann + actualRange = Just (diag ^. LSP.range) + in (expectedRange /= actualRange) + ) + & \case + Nothing -> crash $ "Expected diagnostic not found" <> show range <> ", remaining diagnostics: " <> show diags + Just (_, diags) -> matchDiagnostics rest diags + + popFind :: (a -> Bool) -> [a] -> Maybe (a, [a]) + popFind p = \case + [] -> Nothing + x : xs -> if p x then Just (x, xs) else second (x :) <$> popFind p xs unusedBindingLocations :: Test () unusedBindingLocations = @@ -466,3 +490,33 @@ unusedBindingLocations = |] ) ] + +typeMismatchLocations :: Test () +typeMismatchLocations = + scope "type mismatch locations" . tests . fmap makeDiagnosticRangeTest $ + [ ( "Should highlight the actual incorrect terminal expression in a let block", + [here| +term : Nat +term = + _blah = true + _foo = true + _baz = true + «"incorrect"» + |] + ), + ( "Should highlight the actual incorrect terminal expression in an if-block", + [here| +term : Nat +term = if true + then «"wrong"» + else «"also wrong"» +|] + ), + ( "Should highlight the handler of handle expressions", + [here| +term : Nat +term = + handle "" with const «"wrong"» +|] + ) + ] From 780c91d3704c17095550b24d0c68e65d36f09a07 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 16 Aug 2024 12:53:38 -0700 Subject: [PATCH 3/8] Fix Diagnostic tests --- unison-cli/src/Unison/LSP/FileAnalysis.hs | 15 +++-- unison-cli/tests/Unison/Test/LSP.hs | 68 +++++++++++++++-------- unison-core/src/Unison/Term.hs | 8 +-- 3 files changed, 59 insertions(+), 32 deletions(-) diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index e624de7d51..ee3276743c 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -162,7 +162,8 @@ fileAnalysisWorker = forever do analyseFile :: (Foldable f) => Uri -> Text -> PPED.PrettyPrintEnvDecl -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction]) analyseFile fileUri srcText pped notes = do let ppe = PPED.suffixifiedPPE pped - (noteDiags, noteActions) <- analyseNotes fileUri ppe (Text.unpack srcText) notes + Env {codebase} <- ask + (noteDiags, noteActions) <- analyseNotes codebase fileUri ppe (Text.unpack srcText) notes pure (noteDiags, noteActions) -- | Returns diagnostics which show a warning diagnostic when editing a term that's conflicted in the @@ -210,8 +211,15 @@ getTokenMap tokens = ) & fold -analyseNotes :: (Foldable f) => Uri -> PrettyPrintEnv -> String -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction]) -analyseNotes fileUri ppe src notes = do +analyseNotes :: + (Foldable f, MonadIO m) => + (Codebase.Codebase IO Symbol Ann) -> + Uri -> + PrettyPrintEnv -> + String -> + f (Note Symbol Ann) -> + m ([Diagnostic], [RangedCodeAction]) +analyseNotes codebase fileUri ppe src notes = do flip foldMapM notes \note -> case note of Result.TypeError errNote@(Context.ErrorNote {cause}) -> do let typeErr = TypeError.typeErrorFromNote errNote @@ -364,7 +372,6 @@ analyseNotes fileUri ppe src notes = do typeHoleReplacementCodeActions diags v typ | not (isUserBlank v) = pure [] | otherwise = do - Env {codebase} <- ask let cleanedTyp = Context.generalizeAndUnTypeVar typ -- TODO: is this right? refs <- liftIO . Codebase.runTransaction codebase $ Codebase.termsOfType codebase cleanedTyp forMaybe (toList refs) $ \ref -> runMaybeT $ do diff --git a/unison-cli/tests/Unison/Test/LSP.hs b/unison-cli/tests/Unison/Test/LSP.hs index 3981e8131e..256b1051f4 100644 --- a/unison-cli/tests/Unison/Test/LSP.hs +++ b/unison-cli/tests/Unison/Test/LSP.hs @@ -23,6 +23,7 @@ import Unison.Codebase.SqliteCodebase qualified as SC import Unison.ConstructorReference (GConstructorReference (..)) import Unison.FileParsers qualified as FileParsers import Unison.LSP.Conversions qualified as Cv +import Unison.LSP.FileAnalysis qualified as FileAnalysis import Unison.LSP.FileAnalysis.UnusedBindings qualified as UnusedBindings import Unison.LSP.Queries qualified as LSPQ import Unison.Lexer.Pos qualified as Lexer @@ -31,6 +32,7 @@ import Unison.Parser.Ann qualified as Ann import Unison.Parsers qualified as Parsers import Unison.Pattern qualified as Pattern import Unison.Prelude +import Unison.PrettyPrintEnv qualified as PPE import Unison.Reference qualified as Reference import Unison.Result qualified as Result import Unison.Symbol (Symbol) @@ -426,8 +428,8 @@ withTestCodebase action = do Codebase.Init.withCreatedCodebase SC.init "lsp-test" tmpDir SC.DontLock action either (crash . show) pure r -makeDiagnosticRangeTest :: (String, Text) -> Test () -makeDiagnosticRangeTest (testName, testSrc) = scope testName $ do +makeUnusedBindingRangeTest :: (String, Text) -> Test () +makeUnusedBindingRangeTest (testName, testSrc) = scope testName $ do (cleanSrc, ranges) <- case extractDelimitedBlocks ('«', '»') testSrc of Nothing -> pure (testSrc, []) Just (cleanSrc, ranges) -> pure (cleanSrc, ranges) @@ -439,24 +441,38 @@ makeDiagnosticRangeTest (testName, testSrc) = scope testName $ do let diags = UnusedBindings.analyseTerm (LSP.Uri "test") trm matchDiagnostics ranges diags _ -> crash "Expected exactly one term" - where - matchDiagnostics :: [(Ann, Text)] -> [LSP.Diagnostic] -> Test () - matchDiagnostics ranges diags = case (ranges, diags) of - ([], []) -> pure () - ([], _ : _) -> crash $ "Got diagnostics that weren't matched: " <> show diags - (_ : _, []) -> crash $ "Expected diagnostics that weren't provided" <> show ranges - (range@(ann, _src) : rest, diags) -> - diags - & popFind - ( \diag -> - let expectedRange = Cv.annToRange ann - actualRange = Just (diag ^. LSP.range) - in (expectedRange /= actualRange) - ) - & \case - Nothing -> crash $ "Expected diagnostic not found" <> show range <> ", remaining diagnostics: " <> show diags - Just (_, diags) -> matchDiagnostics rest diags +makeTypecheckerDiagnosticRangeTest :: (String, Text) -> Test () +makeTypecheckerDiagnosticRangeTest (testName, testSrc) = scope testName $ do + (cleanSrc, ranges) <- case extractDelimitedBlocks ('«', '»') testSrc of + Nothing -> pure (testSrc, []) + Just (cleanSrc, ranges) -> pure (cleanSrc, ranges) + (_pf, tf) <- typecheckSrc testName cleanSrc + case tf of + Left notes -> do + let codebase = error "unexpected use of codebase" + let ppe = PPE.empty + (diags, _codeActions) <- FileAnalysis.analyseNotes codebase (LSP.Uri "test") ppe "test" notes + matchDiagnostics ranges diags + Right _ -> crash "Expected typechecking to fail" + +matchDiagnostics :: [(Ann, Text)] -> [LSP.Diagnostic] -> Test () +matchDiagnostics ranges diags = case (ranges, diags) of + ([], []) -> pure () + ([], _ : _) -> crash $ "Got diagnostics that weren't matched: " <> show diags + (_ : _, []) -> crash $ "Expected diagnostics that weren't provided" <> show ranges + (range@(ann, _src) : rest, diags) -> + diags + & popFind + ( \diag -> + let expectedRange = Cv.annToRange ann + actualRange = Just (diag ^. LSP.range) + in (expectedRange /= actualRange) + ) + & \case + Nothing -> crash $ "Expected diagnostic not found" <> show range <> ", remaining diagnostics: " <> show diags + Just (_, diags) -> matchDiagnostics rest diags + where popFind :: (a -> Bool) -> [a] -> Maybe (a, [a]) popFind p = \case [] -> Nothing @@ -464,7 +480,7 @@ makeDiagnosticRangeTest (testName, testSrc) = scope testName $ do unusedBindingLocations :: Test () unusedBindingLocations = - scope "unused bindings" . tests . fmap makeDiagnosticRangeTest $ + scope "unused bindings" . tests . fmap makeUnusedBindingRangeTest $ [ ( "Unused binding in let block", [here|term = usedOne = true @@ -493,10 +509,11 @@ unusedBindingLocations = typeMismatchLocations :: Test () typeMismatchLocations = - scope "type mismatch locations" . tests . fmap makeDiagnosticRangeTest $ + scope "type mismatch locations" . tests . fmap makeTypecheckerDiagnosticRangeTest $ [ ( "Should highlight the actual incorrect terminal expression in a let block", [here| -term : Nat +type Foo = Foo +term : Foo term = _blah = true _foo = true @@ -506,7 +523,8 @@ term = ), ( "Should highlight the actual incorrect terminal expression in an if-block", [here| -term : Nat +type Foo = Foo +term : Foo term = if true then «"wrong"» else «"also wrong"» @@ -514,8 +532,10 @@ term = if true ), ( "Should highlight the handler of handle expressions", [here| -term : Nat +type Foo = Foo +term : Foo term = + const a b = a handle "" with const «"wrong"» |] ) diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index 1dc019e5a6..6b79b6ac34 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -83,18 +83,18 @@ data F typeVar typeAnn patternAnn a | -- Note: let rec blocks have an outer ABT.Cycle which introduces as many -- variables as there are bindings LetRec IsTop [a {- <- bindings -}] a {- <- body -} - -- Note: first parameter is the binding, second is the expression which may refer - | -- to this let bound variable. Constructed as `Let b (abs v e)` + | -- Note: first parameter is the binding, second is the expression which may refer + -- to this let bound variable. Constructed as `Let b (abs v e)` Let IsTop a {- <- binding -} a {- <- body -} -- Pattern matching / eliminating data types, example: -- case x of -- Just n -> rhs1 -- Nothing -> rhs2 - -- + | -- -- translates to -- -- Match x - | -- [ (Constructor 0 [Var], ABT.abs n rhs1) + -- [ (Constructor 0 [Var], ABT.abs n rhs1) -- , (Constructor 1 [], rhs2) ] Match a [MatchCase patternAnn a] | TermLink Referent From 897ac5a9fafadbc66387abe87cda7dff42bb7c9b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 16 Aug 2024 13:39:09 -0700 Subject: [PATCH 4/8] Ormolu --- unison-core/src/Unison/Term.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index 6b79b6ac34..c460e8c6a5 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -83,14 +83,14 @@ data F typeVar typeAnn patternAnn a | -- Note: let rec blocks have an outer ABT.Cycle which introduces as many -- variables as there are bindings LetRec IsTop [a {- <- bindings -}] a {- <- body -} - | -- Note: first parameter is the binding, second is the expression which may refer - -- to this let bound variable. Constructed as `Let b (abs v e)` + -- Note: first parameter is the binding, second is the expression which may refer + | -- to this let bound variable. Constructed as `Let b (abs v e)` Let IsTop a {- <- binding -} a {- <- body -} -- Pattern matching / eliminating data types, example: -- case x of - -- Just n -> rhs1 + | -- Just n -> rhs1 -- Nothing -> rhs2 - | -- + -- -- translates to -- -- Match x From 83ed1ada5c7fddb6f7fbaf2fdb2c65d30f39a653 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 16 Aug 2024 13:40:33 -0700 Subject: [PATCH 5/8] Ormolu --- unison-core/src/Unison/Term.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index c460e8c6a5..652277b121 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -82,13 +82,15 @@ data F typeVar typeAnn patternAnn a | Lam a | -- Note: let rec blocks have an outer ABT.Cycle which introduces as many -- variables as there are bindings - LetRec IsTop [a {- <- bindings -}] a {- <- body -} - -- Note: first parameter is the binding, second is the expression which may refer - | -- to this let bound variable. Constructed as `Let b (abs v e)` - Let IsTop a {- <- binding -} a {- <- body -} - -- Pattern matching / eliminating data types, example: + -- LetRec isTop bindings body + LetRec IsTop [a] a + | -- Note: first parameter is the binding, second is the expression which may refer + -- to this let bound variable. Constructed as `Let b (abs v e)` + -- Let isTop bindings body + Let IsTop a a + | -- Pattern matching / eliminating data types, example: -- case x of - | -- Just n -> rhs1 + -- Just n -> rhs1 -- Nothing -> rhs2 -- -- translates to From 108ed55ac28358baf46b02d5fdb99bbd053eab30 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 16 Aug 2024 17:59:18 -0700 Subject: [PATCH 6/8] Use similar leaf-node logic on other mismatches --- unison-cli/src/Unison/LSP/FileAnalysis.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index ee3276743c..0463ff94c1 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -224,12 +224,9 @@ analyseNotes codebase fileUri ppe src notes = do Result.TypeError errNote@(Context.ErrorNote {cause}) -> do let typeErr = TypeError.typeErrorFromNote errNote ranges = case typeErr of - TypeError.Mismatch {mismatchSite} -> do - let locs = ABT.annotation <$> expressionLeafNodes mismatchSite - (r, rs) <- withNeighbours (locs >>= aToR) - pure (r, ("mismatch",) <$> rs) - TypeError.BooleanMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite - TypeError.ExistentialMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite + TypeError.Mismatch {mismatchSite} -> leafNodeRanges "mismatch" mismatchSite + TypeError.BooleanMismatch {mismatchSite} -> leafNodeRanges "mismatch" mismatchSite + TypeError.ExistentialMismatch {mismatchSite} -> leafNodeRanges "mismatch" mismatchSite TypeError.FunctionApplication {f} -> singleRange $ ABT.annotation f TypeError.NotFunctionApplication {f} -> singleRange $ ABT.annotation f TypeError.AbilityCheckFailure {abilityCheckFailureSite} -> singleRange abilityCheckFailureSite @@ -323,6 +320,10 @@ analyseNotes codebase fileUri ppe src notes = do Context.OtherBug _s -> todoAnnotation pure (noteDiagnostic note ranges, []) where + leafNodeRanges label mismatchSite = do + let locs = ABT.annotation <$> expressionLeafNodes mismatchSite + (r, rs) <- withNeighbours (locs >>= aToR) + pure (r, (label,) <$> rs) -- Diagnostics with this return value haven't been properly configured yet. todoAnnotation = [] singleRange :: Ann -> [(Range, [a])] From e38eebb7d3ea2d6781d5eadf574ccc00fc0cb9cc Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 30 Aug 2024 10:29:48 -0700 Subject: [PATCH 7/8] Detect missing 'do' and provide a hint --- parser-typechecker/src/Unison/PrintError.hs | 18 +++++++++++++++++- parser-typechecker/src/Unison/Typechecker.hs | 13 +++++++++++++ unison-cli/src/Unison/LSP/FileAnalysis.hs | 8 +++++++- 3 files changed, 37 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 74273f12cb..1a5bc23b6b 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -64,6 +64,7 @@ import Unison.Syntax.TermPrinter qualified as TermPrinter import Unison.Term qualified as Term import Unison.Type (Type) import Unison.Type qualified as Type +import Unison.Typechecker qualified as Typechecker import Unison.Typechecker.Context qualified as C import Unison.Typechecker.TypeError import Unison.Typechecker.TypeVar qualified as TypeVar @@ -369,7 +370,7 @@ renderTypeError e env src = case e of Mismatch {..} -> mconcat [ Pr.lines - [ "I found a value of type: " <> style Type1 (renderType' env foundLeaf), + [ "I found a value of type: " <> style Type1 (renderType' env foundLeaf), "where I expected to find: " <> style Type2 (renderType' env expectedLeaf) ], "\n\n", @@ -387,6 +388,7 @@ renderTypeError e env src = case e of src [styleAnnotated Type1 foundLeaf] [styleAnnotated Type2 expectedLeaf], + missingDelayHint, unitHint, intLiteralSyntaxTip mismatchSite expectedType, debugNoteLoc @@ -407,6 +409,20 @@ renderTypeError e env src = case e of debugSummary note ] where + missingDelayHint = case Typechecker.isMismatchMissingDelay foundType expectedType of + Nothing -> "" + Just (Left _) -> + Pr.lines + [ "I expected the expression to be delayed, but it was not.", + "Are you missing a `do`?" + ] + Just (Right _) -> + Pr.lines + [ "", + "I didn't expect this expression to be delayed, but it was.", + "Are you using a `do` where you don't need one,", + "or are you missing a `()` to force an expression?" + ] unitHintMsg = "\nHint: Actions within a block must have type " <> style Type2 (renderType' env expectedLeaf) diff --git a/parser-typechecker/src/Unison/Typechecker.hs b/parser-typechecker/src/Unison/Typechecker.hs index b40b5a5626..87fa838cb5 100644 --- a/parser-typechecker/src/Unison/Typechecker.hs +++ b/parser-typechecker/src/Unison/Typechecker.hs @@ -10,6 +10,7 @@ module Unison.Typechecker isEqual, isSubtype, fitsScheme, + isMismatchMissingDelay, Env (..), Notes (..), Resolution (..), @@ -38,6 +39,7 @@ import Data.Text qualified as Text import Data.Tuple qualified as Tuple import Unison.ABT qualified as ABT import Unison.Blank qualified as B +import Unison.Builtin.Decls qualified as BuiltinDecls import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation) import Unison.Name qualified as Name import Unison.Prelude @@ -48,6 +50,7 @@ import Unison.Syntax.Name qualified as Name (unsafeParseText, unsafeParseVar) import Unison.Term (Term) import Unison.Term qualified as Term import Unison.Type (Type) +import Unison.Type qualified as Type import Unison.Typechecker.Context qualified as Context import Unison.Typechecker.TypeLookup qualified as TL import Unison.Typechecker.TypeVar qualified as TypeVar @@ -405,3 +408,13 @@ wellTyped ppe env term = go <$> runResultT (synthesize ppe Context.PatternMatchC -- `forall a b . a -> b -> a` to be different types -- equals :: Var v => Type v -> Type v -> Bool -- equals t1 t2 = isSubtype t1 t2 && isSubtype t2 t1 + +-- | Checks if the mismatch between two types is due to a missing delay, if so returns a tag for which type is +-- missing the delay +isMismatchMissingDelay :: (Var v) => Type v loc -> Type v loc -> Maybe (Either (Type v loc) (Type v loc)) +isMismatchMissingDelay typeA typeB + | isSubtype (Type.arrow () (Type.ref () BuiltinDecls.unitRef) (typeA $> ())) (typeB $> ()) = + Just (Left typeA) + | isSubtype (ABT.tm (ABT.tm (Type.Ref BuiltinDecls.unitRef) `Type.Arrow` (typeB $> ()))) (typeA $> ()) = + Just (Right typeB) + | otherwise = Nothing diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index 0463ff94c1..d678e56069 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -62,6 +62,7 @@ import Unison.Syntax.Name qualified as Name import Unison.Syntax.Parser qualified as Parser import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Term qualified as Term +import Unison.Typechecker qualified as Typechecker import Unison.Typechecker.Context qualified as Context import Unison.Typechecker.TypeError qualified as TypeError import Unison.UnisonFile qualified as UF @@ -224,7 +225,12 @@ analyseNotes codebase fileUri ppe src notes = do Result.TypeError errNote@(Context.ErrorNote {cause}) -> do let typeErr = TypeError.typeErrorFromNote errNote ranges = case typeErr of - TypeError.Mismatch {mismatchSite} -> leafNodeRanges "mismatch" mismatchSite + TypeError.Mismatch {mismatchSite, foundType, expectedType} + | -- If it's a delay mismatch, the error is likely with the block definition (e.g. missing 'do') so we highlight the whole block. + Just _ <- Typechecker.isMismatchMissingDelay foundType expectedType -> + singleRange $ ABT.annotation mismatchSite + -- Otherwise we highlight the leafe nodes of the block + | otherwise -> leafNodeRanges "mismatch" mismatchSite TypeError.BooleanMismatch {mismatchSite} -> leafNodeRanges "mismatch" mismatchSite TypeError.ExistentialMismatch {mismatchSite} -> leafNodeRanges "mismatch" mismatchSite TypeError.FunctionApplication {f} -> singleRange $ ABT.annotation f From 1a593388cf3e050d90955d519740e9dfa9b2e0f9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 30 Aug 2024 10:29:48 -0700 Subject: [PATCH 8/8] Add transcript and update existing --- unison-src/transcripts/delay-mismatch.md | 14 +++++ .../transcripts/delay-mismatch.output.md | 54 +++++++++++++++++++ unison-src/transcripts/fix2354.output.md | 2 +- unison-src/transcripts/fix614.output.md | 4 +- unison-src/transcripts/hello.output.md | 2 +- 5 files changed, 72 insertions(+), 4 deletions(-) create mode 100644 unison-src/transcripts/delay-mismatch.md create mode 100644 unison-src/transcripts/delay-mismatch.output.md diff --git a/unison-src/transcripts/delay-mismatch.md b/unison-src/transcripts/delay-mismatch.md new file mode 100644 index 0000000000..b2df09efef --- /dev/null +++ b/unison-src/transcripts/delay-mismatch.md @@ -0,0 +1,14 @@ +```ucm +scratch/main> builtins.merge lib.builtins +``` + +```unison:error +missingDo : 'Nat +missingDo = 2 +``` + +```unison:error +superfluousDo : Nat +superfluousDo = do + 2 +``` diff --git a/unison-src/transcripts/delay-mismatch.output.md b/unison-src/transcripts/delay-mismatch.output.md new file mode 100644 index 0000000000..78c24dc8cf --- /dev/null +++ b/unison-src/transcripts/delay-mismatch.output.md @@ -0,0 +1,54 @@ +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. + +``` +``` unison +missingDo : 'Nat +missingDo = 2 +``` + +``` ucm + + Loading changes detected in scratch.u. + + I found a value of type: Nat + where I expected to find: Unit -> Nat + + 1 | missingDo : 'Nat + 2 | missingDo = 2 + + from right here: + + 2 | missingDo = 2 + I expected the expression to be delayed, but it was not. + Are you missing a `do`? + +``` +``` unison +superfluousDo : Nat +superfluousDo = do + 2 +``` + +``` ucm + + Loading changes detected in scratch.u. + + I found a value of type: Unit ->{𝕖} Nat + where I expected to find: Nat + + 1 | superfluousDo : Nat + 2 | superfluousDo = do + 3 | 2 + + from right here: + + 3 | 2 + + I didn't expect this expression to be delayed, but it was. + Are you using a `do` where you don't need one, + or are you missing a `()` to force an expression? + +``` diff --git a/unison-src/transcripts/fix2354.output.md b/unison-src/transcripts/fix2354.output.md index 226d20bc54..b5121d5eee 100644 --- a/unison-src/transcripts/fix2354.output.md +++ b/unison-src/transcripts/fix2354.output.md @@ -12,7 +12,7 @@ x = 'f Loading changes detected in scratch.u. - I found a value of type: (a1 ->{𝕖} a1) ->{𝕖} Nat + I found a value of type: (a1 ->{𝕖} a1) ->{𝕖} Nat where I expected to find: (a -> 𝕣1) -> 𝕣 1 | f : (forall a . a -> a) -> Nat diff --git a/unison-src/transcripts/fix614.output.md b/unison-src/transcripts/fix614.output.md index 97ec65e00a..d55783c428 100644 --- a/unison-src/transcripts/fix614.output.md +++ b/unison-src/transcripts/fix614.output.md @@ -37,7 +37,7 @@ ex2 = do Loading changes detected in scratch.u. - I found a value of type: a ->{Stream a} Unit + I found a value of type: a ->{Stream a} Unit where I expected to find: Unit 2 | Stream.emit @@ -104,7 +104,7 @@ ex4 = Loading changes detected in scratch.u. - I found a value of type: [Nat] + I found a value of type: [Nat] where I expected to find: Unit 2 | [1,2,3] -- no good diff --git a/unison-src/transcripts/hello.output.md b/unison-src/transcripts/hello.output.md index b486a40213..e052846300 100644 --- a/unison-src/transcripts/hello.output.md +++ b/unison-src/transcripts/hello.output.md @@ -84,7 +84,7 @@ hmm = "Not, in fact, a number" Loading changes detected in scratch.u. - I found a value of type: Text + I found a value of type: Text where I expected to find: Nat 1 | hmm : .builtin.Nat