From da449fb415ca7ddba32b1df36b77385270350839 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 8 Jul 2024 16:13:23 -0700 Subject: [PATCH 1/4] Use annotations from Abs instead --- .../Unison/LSP/FileAnalysis/UnusedBindings.hs | 27 +++++++------------ unison-core/src/Unison/Term.hs | 2 +- 2 files changed, 10 insertions(+), 19 deletions(-) diff --git a/unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs b/unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs index af688aa4df..05074f78dc 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs @@ -10,32 +10,23 @@ import U.Core.ABT (ABT (..)) import U.Core.ABT qualified as ABT import Unison.LSP.Conversions qualified as Cv import Unison.LSP.Diagnostics qualified as Diagnostic -import Unison.Lexer.Pos qualified as Pos import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Symbol (Symbol (..)) import Unison.Term (Term) -import Unison.Util.Monoid qualified as Monoid -import Unison.Util.Range qualified as Range import Unison.Var qualified as Var -analyseTerm :: Lsp.Uri -> Ann -> Term Symbol Ann -> [Diagnostic] -analyseTerm fileUri topLevelTermAnn tm = +analyseTerm :: Lsp.Uri -> Term Symbol Ann -> [Diagnostic] +analyseTerm fileUri tm = let (unusedVars, _) = ABT.cata alg tm - -- Unfortunately we don't capture the annotation of the actual binding when parsing :'(, for now the least - -- annoying thing to do is just highlight the top of the binding. - mayRange = - Cv.annToURange topLevelTermAnn - <&> (\(Range.Range start@(Pos.Pos line _col) _end) -> Range.Range start (Pos.Pos line 9999)) - <&> Cv.uToLspRange vars = - Map.toList unusedVars & mapMaybe \(v, _ann) -> do - getRelevantVarName v - in case mayRange of - Nothing -> [] - Just lspRange -> - let bindings = Text.intercalate ", " (tShow <$> vars) - in Monoid.whenM (not $ null vars) [Diagnostic.mkDiagnostic fileUri lspRange Diagnostic.DiagnosticSeverity_Warning ("Unused binding(s) " <> bindings <> " inside this term.\nUse the binding(s), or prefix them with an _ to dismiss this warning.") []] + Map.toList unusedVars & mapMaybe \(v, ann) -> do + (,ann) <$> getRelevantVarName v + diagnostics = + vars & mapMaybe \(varName, ann) -> do + lspRange <- Cv.annToRange ann + pure $ Diagnostic.mkDiagnostic fileUri lspRange Diagnostic.DiagnosticSeverity_Warning ("Unused binding " <> varName <> ". Use the binding, or prefix it with an _ to dismiss this warning.") [] + in diagnostics where getRelevantVarName :: Symbol -> Maybe Text getRelevantVarName = \case diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index c5f6193e1d..2f36dcaa06 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -947,7 +947,7 @@ letRec isTop blockAnn bindings e = (foldr addAbs body bindings) where addAbs :: ((a, v), b) -> ABT.Term f v a -> ABT.Term f v a - addAbs ((_a, v), _b) t = ABT.abs' blockAnn v t + addAbs ((a, v), _b) t = ABT.abs' a v t body :: Term' vt v a body = ABT.tm' blockAnn (LetRec isTop (map snd bindings) e) From ee6793bd27dd74fb23d2c7d4b82c6a668ce715b3 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 8 Jul 2024 16:13:23 -0700 Subject: [PATCH 2/4] Attempt to fix Unused Binding locations --- .../src/Unison/Syntax/TermParser.hs | 16 ++++++------ .../src/Unison/Typechecker/Components.hs | 7 ++---- unison-cli/src/Unison/LSP/FileAnalysis.hs | 5 +++- unison-cli/src/Unison/LSP/Queries.hs | 14 ++++++++--- unison-core/src/Unison/Term.hs | 25 ++++++++++++------- unison-syntax/src/Unison/Lexer/Pos.hs | 12 ++------- unison-syntax/src/Unison/Syntax/Lexer.hs | 2 -- 7 files changed, 43 insertions(+), 38 deletions(-) diff --git a/parser-typechecker/src/Unison/Syntax/TermParser.hs b/parser-typechecker/src/Unison/Syntax/TermParser.hs index 044a29ead5..cfa25490d4 100644 --- a/parser-typechecker/src/Unison/Syntax/TermParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TermParser.hs @@ -38,8 +38,8 @@ import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Names qualified as Names import Unison.NamesWithHistory qualified as Names -import Unison.Parser.Ann qualified as Ann import Unison.Parser.Ann (Ann) +import Unison.Parser.Ann qualified as Ann import Unison.Pattern (Pattern) import Unison.Pattern qualified as Pattern import Unison.Prelude @@ -412,7 +412,7 @@ hashQualifiedPrefixTerm = resolveHashQualified =<< hqPrefixId hashQualifiedInfixTerm :: (Monad m, Var v) => TermP v m hashQualifiedInfixTerm = resolveHashQualified =<< hqInfixId -quasikeyword :: Ord v => Text -> P v m (L.Token ()) +quasikeyword :: (Ord v) => Text -> P v m (L.Token ()) quasikeyword kw = queryToken \case L.WordyId (HQ'.NameOnly n) | nameIsKeyword n kw -> Just () _ -> Nothing @@ -993,10 +993,10 @@ bang = P.label "bang" do e <- termLeaf pure $ DD.forceTerm (ann start <> ann e) (ann start) e -force :: forall m v . (Monad m, Var v) => TermP v m +force :: forall m v. (Monad m, Var v) => TermP v m force = P.label "force" $ P.try do -- `forkAt pool() blah` parses as `forkAt (pool ()) blah` - -- That is, empty parens immediately (no space) following a symbol + -- That is, empty parens immediately (no space) following a symbol -- is treated as high precedence function application of `Unit` fn <- hashQualifiedPrefixTerm tok <- ann <$> openBlockWith "(" @@ -1008,10 +1008,10 @@ seqOp :: (Ord v) => P v m Pattern.SeqOp seqOp = Pattern.Snoc <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.snocSegment))) - <|> Pattern.Cons - <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.consSegment))) - <|> Pattern.Concat - <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.concatSegment))) + <|> Pattern.Cons + <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.consSegment))) + <|> Pattern.Concat + <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.concatSegment))) term4 :: (Monad m, Var v) => TermP v m term4 = f <$> some termLeaf diff --git a/parser-typechecker/src/Unison/Typechecker/Components.hs b/parser-typechecker/src/Unison/Typechecker/Components.hs index ccef8995d3..72dac37113 100644 --- a/parser-typechecker/src/Unison/Typechecker/Components.hs +++ b/parser-typechecker/src/Unison/Typechecker/Components.hs @@ -78,7 +78,7 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop blockAnn bs e) = blockAnn [(annotatedVar hdv, hdb)] e - | otherwise = Term.singleLet isTop blockAnn (hdv, hdb) e + | otherwise = Term.singleLet isTop blockAnn (annotationFor hdv) (hdv, hdb) e mklet cycle@((_, _) : _) e = Term.letRec isTop @@ -86,10 +86,7 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop blockAnn bs e) = (first annotatedVar <$> cycle) e mklet [] e = e - in -- The outer annotation is going to be meaningful, so we make - -- sure to preserve it, whereas the annotations at intermediate Abs - -- nodes aren't necessarily meaningful - Right . Just . ABT.annotate blockAnn . foldr mklet e $ cs + in Right . Just . foldr mklet e $ cs minimize _ = Right Nothing minimize' :: diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index ddd7fc477c..d6c6e678f9 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -29,6 +29,7 @@ import Unison.Cli.UniqueTypeGuidLookup qualified as Cli import Unison.Codebase qualified as Codebase import Unison.DataDeclaration qualified as DD import Unison.Debug qualified as Debug +import Debug.Trace import Unison.FileParsers (ShouldUseTndr (..)) import Unison.FileParsers qualified as FileParsers import Unison.KindInference.Error qualified as KindInference @@ -111,8 +112,10 @@ checkFile doc = runMaybeT do & foldMap (\(RangedCodeAction {_codeActionRanges, _codeAction}) -> (,_codeAction) <$> _codeActionRanges) & toRangeMap let typeSignatureHints = fromMaybe mempty (mkTypeSignatureHints <$> parsedFile <*> typecheckedFile) + for_ (parsedFile & foldMap (Map.toList . UF.terms )) \(v, (_, trm)) -> do + traceM (show $ (v, trm)) let fileSummary = FileSummary.mkFileSummary parsedFile typecheckedFile - let unusedBindingDiagnostics = fileSummary ^.. _Just . to termsBySymbol . folded . folding (\(topLevelAnn, _refId, trm, _type) -> UnusedBindings.analyseTerm fileUri topLevelAnn trm) + let unusedBindingDiagnostics = fileSummary ^.. _Just . to termsBySymbol . folded . folding (\(_topLevelAnn, _refId, trm, _type) -> UnusedBindings.analyseTerm fileUri trm) let tokenMap = getTokenMap tokens conflictWarningDiagnostics <- fold <$> for fileSummary \fs -> diff --git a/unison-cli/src/Unison/LSP/Queries.hs b/unison-cli/src/Unison/LSP/Queries.hs index b6e87497cf..d8391b8bf7 100644 --- a/unison-cli/src/Unison/LSP/Queries.hs +++ b/unison-cli/src/Unison/LSP/Queries.hs @@ -198,14 +198,14 @@ instance Functor SourceNode where -- children contain that position. findSmallestEnclosingNode :: Pos -> Term Symbol Ann -> Maybe (SourceNode Ann) findSmallestEnclosingNode pos term - | annIsFilePosition (ABT.annotation term) && not (ABT.annotation term `Ann.contains` pos) = Nothing + | annIsFilePosition ann && not (ann `Ann.contains` pos) = Nothing | Just r <- cleanImplicitUnit term = findSmallestEnclosingNode pos r | otherwise = do -- For leaf nodes we require that they be an in-file position, not Intrinsic or -- external. -- In some rare cases it's possible for an External/Intrinsic node to have children that -- ARE in the file, so we need to make sure we still crawl their children. - let guardInFile = guard (annIsFilePosition (ABT.annotation term)) + let guardInFile = guard (annIsFilePosition ann) let bestChild = case ABT.out term of ABT.Tm f -> case f of Term.Int {} -> guardInFile *> Just (TermNode term) @@ -244,7 +244,7 @@ findSmallestEnclosingNode pos term ABT.Var _v -> guardInFile *> Just (TermNode term) ABT.Cycle r -> findSmallestEnclosingNode pos r ABT.Abs _v r -> findSmallestEnclosingNode pos r - let fallback = if annIsFilePosition (ABT.annotation term) then Just (TermNode term) else Nothing + let fallback = if annIsFilePosition ann then Just (TermNode term) else Nothing bestChild <|> fallback where -- tuples always end in an implicit unit, but it's annotated with the span of the whole @@ -256,6 +256,14 @@ findSmallestEnclosingNode pos term ABT.Tm' (Term.App (ABT.Tm' (Term.App (ABT.Tm' (Term.Constructor (ConstructorReference ref 0))) x)) trm) | ref == Builtins.pairRef && Term.amap (const ()) trm == Builtins.unitTerm () -> Just x _ -> Nothing + ann = getTermSpanAnn term + + +-- | Most nodes have the property that their annotation spans all their children, but there are some exceptions. +getTermSpanAnn :: Term Symbol Ann -> Ann +getTermSpanAnn tm = case ABT.out tm of + ABT.Abs _v r -> ABT.annotation tm <> getTermSpanAnn r + _ -> ABT.annotation tm findSmallestEnclosingPattern :: Pos -> Pattern.Pattern Ann -> Maybe (Pattern.Pattern Ann) findSmallestEnclosingPattern pos pat diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index 2f36dcaa06..3bd9336c75 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -866,9 +866,14 @@ ann :: Term2 vt at ap v a ann a e t = ABT.tm' a (Ann e t) --- arya: are we sure we want the two annotations to be the same? -lam :: (Ord v) => a -> v -> Term2 vt at ap v a -> Term2 vt at ap v a -lam a v body = ABT.tm' a (Lam (ABT.abs' a v body)) +lam :: + (Ord v) => + a -> + -- Annotation for just the variable binding + (a, v) -> + Term2 vt at ap v a -> + Term2 vt at ap v a +lam spanAnn (bindingAnn, v) body = ABT.tm' spanAnn (Lam (ABT.abs' bindingAnn v body)) delay :: (Var v) => a -> Term2 vt at ap v a -> Term2 vt at ap v a delay a body = @@ -978,7 +983,7 @@ let1 :: Term2 vt at ap v a let1 isTop bindings e = foldr f e bindings where - f ((ann, v), b) body = ABT.tm' (ann <> ABT.annotation body) (Let isTop b (ABT.abs' (ABT.annotation body) v body)) + f ((ann, v), b) body = ABT.tm' (ann <> ABT.annotation body) (Let isTop b (ABT.abs' ann v body)) let1' :: (Semigroup a, Ord v) => @@ -997,12 +1002,14 @@ let1' isTop bindings e = foldr f e bindings singleLet :: (Ord v) => IsTop -> - -- Annotation spanning the whole let-binding + -- Annotation spanning the let-binding and its body + a -> + -- Annotation for just the binding, not the body it's used in. a -> (v, Term2 vt at ap v a) -> Term2 vt at ap v a -> Term2 vt at ap v a -singleLet isTop a (v, body) e = ABT.tm' a (Let isTop body (ABT.abs' a v e)) +singleLet isTop spanAnn absAnn (v, body) e = ABT.tm' spanAnn (Let isTop body (ABT.abs' absAnn v e)) -- let1' :: Var v => [(Text, Term0 vt v)] -> Term0 vt v -> Term0 vt v -- let1' bs e = let1 [(ABT.v' name, b) | (name,b) <- bs ] e @@ -1383,7 +1390,7 @@ containsExpression = ABT.containsExpression -- Used to find matches of `@rewrite case` rules -- Returns `Nothing` if `pat` can't be interpreted as a `Pattern` -- (like `1 + 1` is not a valid pattern, but `Some x` can be) -containsCaseTerm :: Var v1 => Term2 tv ta tb v1 loc -> Term2 typeVar typeAnn loc v2 a -> Maybe Bool +containsCaseTerm :: (Var v1) => Term2 tv ta tb v1 loc -> Term2 typeVar typeAnn loc v2 a -> Maybe Bool containsCaseTerm pat = (\tm -> containsCase <$> pat' <*> pure tm) where @@ -1456,7 +1463,7 @@ rewriteCasesLHS pat0 pat0' = go t = t -- Implementation detail of `@rewrite case` rules (both find and replace) -toPattern :: Var v => Term2 tv ta tb v loc -> Maybe (Pattern loc) +toPattern :: (Var v) => Term2 tv ta tb v loc -> Maybe (Pattern loc) toPattern tm = case tm of Var' v | "_" `Text.isPrefixOf` Var.name v -> pure $ Pattern.Unbound loc Var' _ -> pure $ Pattern.Var loc @@ -1484,7 +1491,7 @@ toPattern tm = case tm of loc = ABT.annotation tm -- Implementation detail of `@rewrite case` rules (both find and replace) -matchCaseFromTerm :: Var v => Term2 typeVar typeAnn a v a -> Maybe (MatchCase a (Term2 typeVar typeAnn a v a)) +matchCaseFromTerm :: (Var v) => Term2 typeVar typeAnn a v a -> Maybe (MatchCase a (Term2 typeVar typeAnn a v a)) matchCaseFromTerm (App' (Builtin' "#case") (ABT.unabsA -> (_, Apps' _ci [pat, guard, body]))) = do p <- toPattern pat let g = unguard guard diff --git a/unison-syntax/src/Unison/Lexer/Pos.hs b/unison-syntax/src/Unison/Lexer/Pos.hs index b3297b9221..9286d36b05 100644 --- a/unison-syntax/src/Unison/Lexer/Pos.hs +++ b/unison-syntax/src/Unison/Lexer/Pos.hs @@ -4,21 +4,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -module Unison.Lexer.Pos (Pos (..), Line, Column, line, column) where +module Unison.Lexer.Pos (Pos (..), Line, Column) where type Line = Int type Column = Int -data Pos = Pos {-# UNPACK #-} !Line {-# UNPACK #-} !Column deriving (Eq, Ord) - -line :: Pos -> Line -line (Pos line _) = line - -column :: Pos -> Column -column (Pos _ column) = column - -instance Show Pos where show (Pos line col) = "line " <> show line <> ", column " <> show col +data Pos = Pos { line :: {-# UNPACK #-} !Line, column :: {-# UNPACK #-} !Column} deriving (Show, Eq, Ord) instance Semigroup Pos where Pos line col <> Pos line2 col2 = diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 6ff55150f7..6a2d74911e 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -8,8 +8,6 @@ module Unison.Syntax.Lexer Pos (..), Lexeme (..), lexer, - line, - column, escapeChars, debugFileLex, debugLex', From 7c52443a0145006e3733f4d94df348bcfdf6a835 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 12 Jul 2024 11:20:31 -0700 Subject: [PATCH 3/4] Merge trunk From 11208f52843d6fa92a1b3771d75492fa1dabfb4d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 12 Jul 2024 11:20:31 -0700 Subject: [PATCH 4/4] Add unused binding test --- parser-typechecker/tests/Unison/Test/Term.hs | 2 +- unison-cli/src/Unison/LSP/Diagnostics.hs | 7 +- unison-cli/src/Unison/LSP/FileAnalysis.hs | 8 +- .../Unison/LSP/FileAnalysis/UnusedBindings.hs | 7 +- unison-cli/tests/Unison/Test/LSP.hs | 100 +++++++++++++++--- 5 files changed, 100 insertions(+), 24 deletions(-) diff --git a/parser-typechecker/tests/Unison/Test/Term.hs b/parser-typechecker/tests/Unison/Test/Term.hs index 31122f5aac..4791382bd9 100644 --- a/parser-typechecker/tests/Unison/Test/Term.hs +++ b/parser-typechecker/tests/Unison/Test/Term.hs @@ -57,7 +57,7 @@ test = ref = R.Id h 0 v1 = Var.unnamedRef @Symbol ref -- input component: `ref = \v1 -> ref` - component = Map.singleton ref (Term.lam () v1 (Term.refId () ref)) + component = Map.singleton ref (Term.lam () ((), v1) (Term.refId () ref)) component' = Term.unhashComponent component -- expected unhashed component: `v2 = \v1 -> v2`, where `v2 /= v1`, -- i.e. `v2` cannot be just `ref` converted to a ref-named variable, diff --git a/unison-cli/src/Unison/LSP/Diagnostics.hs b/unison-cli/src/Unison/LSP/Diagnostics.hs index bf9d154980..9416fec9bb 100644 --- a/unison-cli/src/Unison/LSP/Diagnostics.hs +++ b/unison-cli/src/Unison/LSP/Diagnostics.hs @@ -9,6 +9,7 @@ import Language.LSP.Protocol.Message qualified as Msg import Language.LSP.Protocol.Types import Unison.LSP.Types import Unison.Prelude +import Unison.Util.Monoid qualified as Monoid reportDiagnostics :: (Foldable f) => @@ -23,15 +24,15 @@ reportDiagnostics docUri fileVersion diags = do let params = PublishDiagnosticsParams {_uri = docUri, _version = fromIntegral <$> fileVersion, _diagnostics = toList $ diags} sendNotification (Msg.TNotificationMessage jsonRPC Msg.SMethod_TextDocumentPublishDiagnostics params) -mkDiagnostic :: Uri -> Range -> DiagnosticSeverity -> Text -> [(Text, Range)] -> Diagnostic -mkDiagnostic uri r severity msg references = +mkDiagnostic :: Uri -> Range -> DiagnosticSeverity -> [DiagnosticTag] -> Text -> [(Text, Range)] -> Diagnostic +mkDiagnostic uri r severity tags msg references = Diagnostic { _range = r, _severity = Just severity, _code = Nothing, -- We could eventually pass error codes here _source = Just "unison", _message = msg, - _tags = Nothing, + _tags = Monoid.whenM (not $ null tags) (Just tags), _relatedInformation = case references of [] -> Nothing diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index 76a6e8531b..221e8957f1 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -29,7 +29,6 @@ import Unison.Cli.UniqueTypeGuidLookup qualified as Cli import Unison.Codebase qualified as Codebase import Unison.DataDeclaration qualified as DD import Unison.Debug qualified as Debug -import Debug.Trace import Unison.FileParsers (ShouldUseTndr (..)) import Unison.FileParsers qualified as FileParsers import Unison.KindInference.Error qualified as KindInference @@ -112,8 +111,6 @@ checkFile doc = runMaybeT do & foldMap (\(RangedCodeAction {_codeActionRanges, _codeAction}) -> (,_codeAction) <$> _codeActionRanges) & toRangeMap let typeSignatureHints = fromMaybe mempty (mkTypeSignatureHints <$> parsedFile <*> typecheckedFile) - for_ (parsedFile & foldMap (Map.toList . UF.terms )) \(v, (_, trm)) -> do - traceM (show $ (v, trm)) let fileSummary = FileSummary.mkFileSummary parsedFile typecheckedFile let unusedBindingDiagnostics = fileSummary ^.. _Just . to termsBySymbol . folded . folding (\(_topLevelAnn, _refId, trm, _type) -> UnusedBindings.analyseTerm fileUri trm) let tokenMap = getTokenMap tokens @@ -197,6 +194,7 @@ computeConflictWarningDiagnostics fileUri fileSummary@FileSummary {fileNames} = fileUri newRange DiagnosticSeverity_Information + [] msg mempty pure $ toDiagnostics conflictedTermLocations <> toDiagnostics conflictedTypeLocations @@ -283,7 +281,7 @@ analyseNotes fileUri ppe src notes = do (errMsg, ranges) <- PrintError.renderParseErrors src err let txtMsg = Text.pack $ Pretty.toPlain 80 errMsg range <- ranges - pure $ mkDiagnostic fileUri (uToLspRange range) DiagnosticSeverity_Error txtMsg [] + pure $ mkDiagnostic fileUri (uToLspRange range) DiagnosticSeverity_Error [] txtMsg [] -- TODO: Some parsing errors likely have reasonable code actions pure (diags, []) Result.UnknownSymbol _ loc -> @@ -339,7 +337,7 @@ analyseNotes fileUri ppe src notes = do let msg = Text.pack $ Pretty.toPlain 80 $ PrintError.printNoteWithSource ppe src note in do (range, references) <- ranges - pure $ mkDiagnostic fileUri range DiagnosticSeverity_Error msg references + pure $ mkDiagnostic fileUri range DiagnosticSeverity_Error [] msg references -- Suggest name replacements or qualifications when there's ambiguity nameResolutionCodeActions :: [Diagnostic] -> [Context.Suggestion Symbol Ann] -> [RangedCodeAction] nameResolutionCodeActions diags suggestions = do diff --git a/unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs b/unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs index 05074f78dc..46d87c6ec1 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs @@ -14,6 +14,7 @@ import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Symbol (Symbol (..)) import Unison.Term (Term) +import Unison.Util.Range qualified as Range import Unison.Var qualified as Var analyseTerm :: Lsp.Uri -> Term Symbol Ann -> [Diagnostic] @@ -24,8 +25,10 @@ analyseTerm fileUri tm = (,ann) <$> getRelevantVarName v diagnostics = vars & mapMaybe \(varName, ann) -> do - lspRange <- Cv.annToRange ann - pure $ Diagnostic.mkDiagnostic fileUri lspRange Diagnostic.DiagnosticSeverity_Warning ("Unused binding " <> varName <> ". Use the binding, or prefix it with an _ to dismiss this warning.") [] + -- Limit the range to the first line of the binding to not be too annoying. + -- Maybe in the future we can get the actual annotation of the variable name. + lspRange <- Cv.uToLspRange . Range.startingLine <$> Cv.annToURange ann + pure $ Diagnostic.mkDiagnostic fileUri lspRange Diagnostic.DiagnosticSeverity_Warning [Lsp.DiagnosticTag_Unnecessary] ("Unused binding " <> tShow varName <> ". Use the binding, or prefix it with an _ to dismiss this warning.") [] in diagnostics where getRelevantVarName :: Symbol -> Maybe Text diff --git a/unison-cli/tests/Unison/Test/LSP.hs b/unison-cli/tests/Unison/Test/LSP.hs index 5b42467905..880fd6214b 100644 --- a/unison-cli/tests/Unison/Test/LSP.hs +++ b/unison-cli/tests/Unison/Test/LSP.hs @@ -10,6 +10,8 @@ import Data.String.Here.Uninterpolated (here) import Data.Text import Data.Text qualified as Text import EasyTest +import Language.LSP.Protocol.Lens qualified as LSP +import Language.LSP.Protocol.Types qualified as LSP import System.IO.Temp qualified as Temp import Unison.ABT qualified as ABT import Unison.Builtin.Decls (unitRef) @@ -20,6 +22,8 @@ import Unison.Codebase.Init qualified as Codebase.Init 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.UnusedBindings qualified as UnusedBindings import Unison.LSP.Queries qualified as LSPQ import Unison.Lexer.Pos qualified as Lexer import Unison.Parser.Ann (Ann (..)) @@ -43,6 +47,10 @@ test = do [ refFinding, annotationNesting ] + scope "diagnostics" $ + tests + [ unusedBindingLocations + ] trm :: Term.F Symbol () () (ABT.Term (Term.F Symbol () ()) Symbol ()) -> LSPQ.SourceNode () trm = LSPQ.TermNode . ABT.tm @@ -239,15 +247,39 @@ term = let ) ] --- | Test helper which lets you specify a cursor position inline with source text as a '|'. +-- | Test helper which lets you specify a cursor position inline with source text as a '^'. extractCursor :: Text -> Test (Lexer.Pos, Text) extractCursor txt = - case Text.splitOn "^" txt of + case splitOnDelimiter '^' txt of + Nothing -> crash "expected exactly one cursor" + Just (before, pos, after) -> pure (pos, before <> after) + +-- | 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") +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 - line = Prelude.length $ Text.lines before - in pure $ (Lexer.Pos line col, before <> after) - _ -> crash "expected exactly one cursor" + let col = (Text.length $ Text.takeWhileEnd (/= '\n') before) + 1 + line = Text.count "\n" before + 1 + in Just $ (before, Lexer.Pos line col, after) + _ -> Nothing + +-- | Test helper which lets you specify a cursor position inline with source text as a '^'. +-- +-- >>> extractDelimitedBlock ('{', '}') "foo {bar} baz" +-- Just (Ann {start = Pos {line = 1, column = 4}, end = Pos {line = 1, column = 7}},"bar","foo bar baz") +-- +-- >>> 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) makeNodeSelectionTest :: (String, Text, Bool, LSPQ.SourceNode ()) -> Test () makeNodeSelectionTest (name, testSrc, testTypechecked, expected) = scope name $ do @@ -308,7 +340,7 @@ annotationNestingTest (name, src) = scope name do & traverse_ \(_fileAnn, _refId, _wk, trm, _typ) -> assertAnnotationsAreNested trm --- | Asserts that for all nodes in the provided ABT, the annotations of all child nodes are +-- | Asserts that for all nodes in the provided ABT EXCEPT Abs nodes, the annotations of all child nodes are -- within the span of the parent node. assertAnnotationsAreNested :: forall f. (Foldable f, Functor f, Show (f (Either String Ann))) => ABT.Term f Symbol Ann -> Test () assertAnnotationsAreNested term = do @@ -319,12 +351,19 @@ assertAnnotationsAreNested term = do alg :: Ann -> ABT.ABT f Symbol (Either String Ann) -> Either String Ann alg ann abt = do childSpan <- abt & foldMapM id - case ann `Ann.encompasses` childSpan of - -- one of the annotations isn't in the file, don't bother checking. - Nothing -> pure (ann <> childSpan) - Just isInFile - | isInFile -> pure ann - | otherwise -> Left $ "Containment breach: children aren't contained with the parent:" <> show (ann, abt) + case abt of + -- Abs nodes are the only nodes whose annotations are allowed to not contain their children, + -- they represet the location of the variable being bound instead. Ideally we'd have a separate child + -- node for that, but we can't add it without editing the ABT or Term types. + ABT.Abs _ _ -> + pure (ann <> childSpan) + _ -> do + case ann `Ann.encompasses` childSpan of + -- one of the annotations isn't in the file, don't bother checking. + Nothing -> pure (ann <> childSpan) + Just isInFile + | isInFile -> pure ann + | otherwise -> Left $ "Containment breach: children aren't contained with the parent:" <> show (ann, abt) typecheckSrc :: String -> @@ -374,3 +413,38 @@ withTestCodebase action = do tmpDir <- Temp.createTempDirectory tmp "lsp-test" 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 + (ann, _block, cleanSrc) <- case extractDelimitedBlock ('«', '»') testSrc of + Nothing -> crash "expected exactly one delimited block" + Just r -> pure r + (pf, _mayTypecheckedFile) <- typecheckSrc testName cleanSrc + UF.terms pf + & Map.elems + & \case + [(_a, trm)] -> do + case UnusedBindings.analyseTerm (LSP.Uri "test") trm of + [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 + _ -> crash "Expected exactly one diagnostic" + _ -> crash "Expected exactly one term" + +unusedBindingLocations :: Test () +unusedBindingLocations = + scope "unused bindings" . tests . fmap makeDiagnosticRangeTest $ + [ ( "Unused binding in let block", + [here|term = + usedOne = true + «unused = "unused"» + usedTwo = false + usedOne && usedTwo + |] + ), + ( "Unused argument", + [here|term «unused» = 1|] + ) + ]