Merge pull request #5218 from unisonweb/lsp/fix-unused-binding-locs

parser-typechecker/src/Unison/Builtin/Decls.hs

@@ -776,8 +776,8 @@ tupleTerm = foldr tupleConsTerm (unitTerm mempty)
 forceTerm :: (Var v) => a -> a -> Term v a -> Term v a
 forceTerm a au e = Term.app a e (unitTerm au)
 
-delayTerm :: (Var v) => a -> Term v a -> Term v a
-delayTerm a = Term.lam a $ Var.typed Var.Delay
+delayTerm :: (Var v) => a -> a -> Term v a -> Term v a
+delayTerm spanAnn argAnn = Term.lam spanAnn (argAnn, Var.typed Var.Delay)
 
 unTupleTerm ::
   Term.Term2 vt at ap v a ->

parser-typechecker/src/Unison/Runtime/ANF.hs

@@ -169,7 +169,7 @@ expandSimple keep (v, bnd) = (v, apps' (var a v) evs)
     evs = map (var a) . Set.toList $ Set.difference fvs keep
 
 abstract :: (Var v) => Set v -> Term v a -> Term v a
-abstract keep bnd = lam' a evs bnd
+abstract keep bnd = lamWithoutBindingAnns a evs bnd
   where
     a = ABT.annotation bnd
     fvs = ABT.freeVars bnd
@@ -205,7 +205,7 @@ enclose keep rec (Let1NamedTop' top v b@(unAnn -> LamsNamed' vs bd) e) =
     annotate tm
       | Ann' _ ty <- b = ann a tm ty
       | otherwise = tm
-    lamb = lam' a evs (annotate $ lam' a vs lbody)
+    lamb = lamWithoutBindingAnns a evs (annotate $ lamWithoutBindingAnns a vs lbody)
 enclose keep rec t@(unLamsAnnot -> Just (vs0, mty, vs1, body)) =
   Just $ if null evs then lamb else apps' lamb $ map (var a) evs
   where
@@ -218,7 +218,7 @@ enclose keep rec t@(unLamsAnnot -> Just (vs0, mty, vs1, body)) =
     annotate tm
       | Just ty <- mty = ann a tm ty
       | otherwise = tm
-    lamb = lam' a (evs ++ vs0) . annotate . lam' a vs1 $ lbody
+    lamb = lamWithoutBindingAnns a (evs ++ vs0) . annotate . lamWithoutBindingAnns a vs1 $ lbody
 enclose keep rec t@(Handle' h body)
   | isStructured body =
       Just . handle (ABT.annotation t) (rec keep h) $ apps' lamb args
@@ -232,8 +232,8 @@ enclose keep rec t@(Handle' h body)
       | null evs = [constructor a (ConstructorReference Ty.unitRef 0)]
       | otherwise = var a <$> evs
     lamb
-      | null evs = lam' a [fv] lbody
-      | otherwise = lam' a evs lbody
+      | null evs = lamWithoutBindingAnns a [fv] lbody
+      | otherwise = lamWithoutBindingAnns a evs lbody
 enclose keep rec t@(Match' s0 cs0) = Just $ match a s cs
   where
     a = ABT.annotation t
@@ -331,7 +331,7 @@ beta rec (LetRecNamedTop' top (fmap (fmap rec) -> vbs) (rec -> bd)) =
       vbs <&> \(v, b0) -> (v,ABT.annotation b0,) $ case b0 of
         LamsNamed' vs b
           | Just n <- Map.lookup v m ->
-              lam' (ABT.annotation b0) (drop n vs) (dropPrefixes m b)
+              lamWithoutBindingAnns (ABT.annotation b0) (drop n vs) (dropPrefixes m b)
         -- shouldn't happen
         b -> dropPrefixes m b
 
@@ -340,7 +340,7 @@ beta rec (Let1NamedTop' top v l@(LamsNamed' vs bd) (rec -> e))
   | n > 0 = Just $ let1' top [(v, lamb)] (dropPrefix v n e)
   | otherwise = Nothing
   where
-    lamb = lam' al (drop n vs) (bd)
+    lamb = lamWithoutBindingAnns al (drop n vs) (bd)
     al = ABT.annotation l
     -- Calculate a maximum number of arguments to drop.
     -- Enclosing doesn't create let-bound lambdas, so we
@@ -353,7 +353,7 @@ beta rec (Let1NamedTop' top v l@(LamsNamed' vs bd) (rec -> e))
 beta rec (Apps' l@(LamsNamed' vs body) as)
   | n <- matchVars 0 vs as,
     n > 0 =
-      Just $ apps' (lam' al (drop n vs) (rec body)) (drop n as)
+      Just $ apps' (lamWithoutBindingAnns al (drop n vs) (rec body)) (drop n as)
   | otherwise = Nothing
   where
     al = ABT.annotation l
@@ -422,7 +422,7 @@ groupFloater rec vbs = do
   where
     rec' b
       | Just (vs0, mty, vs1, bd) <- unLamsAnnot b =
-          lam' a vs0 . maybe id (flip $ ann a) mty . lam' a vs1 <$> rec bd
+          lamWithoutBindingAnns a vs0 . maybe id (flip $ ann a) mty . lamWithoutBindingAnns a vs1 <$> rec bd
       where
         a = ABT.annotation b
     rec' b = rec b
@@ -453,12 +453,12 @@ lamFloater closed tm mv a vs bd =
       let v = ABT.freshIn cvs $ fromMaybe (typed Var.Float) mv
        in ( v,
             ( Set.insert v cvs,
-              ctx <> [(v, lam' a vs bd)],
+              ctx <> [(v, lamWithoutBindingAnns a vs bd)],
               floatDecomp closed v tm dcmp
             )
           )
   where
-    tgt = unannotate (lam' a vs bd)
+    tgt = unannotate (lamWithoutBindingAnns a vs bd)
     p (_, flam) = unannotate flam == tgt
 
 floatDecomp ::
@@ -479,7 +479,7 @@ floater top rec tm0@(Ann' tm ty) =
 floater top rec (LetRecNamed' vbs e) =
   Just $
     letFloater rec vbs e >>= \case
-      lm@(LamsNamed' vs bd) | top -> lam' a vs <$> rec bd
+      lm@(LamsNamed' vs bd) | top -> lamWithoutBindingAnns a vs <$> rec bd
         where
           a = ABT.annotation lm
       tm -> rec tm
@@ -492,7 +492,7 @@ floater _ rec (Let1Named' v b e)
   where
     a = ABT.annotation b
 floater top rec tm@(LamsNamed' vs bd)
-  | top = Just $ lam' a vs <$> rec bd
+  | top = Just $ lamWithoutBindingAnns a vs <$> rec bd
   | otherwise = Just $ do
       bd <- rec bd
       lv <- lamFloater True tm Nothing a vs bd
@@ -627,7 +627,7 @@ saturate dat = ABT.visitPure $ \case
         | m < n,
           vs <- snd $ mapAccumL frsh fvs [1 .. n - m],
           nargs <- var mempty <$> vs ->
-            Just . lam' mempty vs . apps' f $ args' ++ nargs
+            Just . lamWithoutBindingAnns mempty vs . apps' f $ args' ++ nargs
         | m > n,
           (sargs, eargs) <- splitAt n args',
           sv <- Var.freshIn fvs $ typed Var.Eta ->

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
@@ -348,7 +348,9 @@ parsePattern = label "pattern" root
 lam :: (Var v) => TermP v m -> TermP v m
 lam p = label "lambda" $ mkLam <$> P.try (some prefixDefinitionName <* reserved "->") <*> p
   where
-    mkLam vs b = Term.lam' (ann (head vs) <> ann b) (map L.payload vs) b
+    mkLam vs b =
+      let annotatedArgs = vs <&> \v -> (ann v, L.payload v)
+       in Term.lam' (ann (head vs) <> ann b) annotatedArgs b
 
 letBlock, handle, ifthen :: (Monad m, Var v) => TermP v m
 letBlock = label "let" $ (snd <$> block "let")
@@ -383,7 +385,8 @@ lamCase = do
         es -> DD.tupleTerm es
       anns = ann start <> ann (NonEmpty.last cases)
       matchTerm = Term.match anns lamvarTerm (toList cases)
-  pure $ Term.lam' anns vars matchTerm
+  let annotatedVars = (Ann.GeneratedFrom $ ann start,) <$> vars
+  pure $ Term.lam' anns annotatedVars matchTerm
 
 ifthen = label "if" do
   start <- peekAny
@@ -412,7 +415,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
@@ -595,11 +598,12 @@ doc2Block = do
           "syntax.docExample" -> do
             trm <- term
             endTok <- closeBlock
-            pure . (ann startTok <> ann endTok,) $ case trm of
+            let spanAnn = ann startTok <> ann endTok
+            pure . (spanAnn,) $ case trm of
               tm@(Term.Apps' _ xs) ->
                 let fvs = List.Extra.nubOrd $ concatMap (toList . Term.freeVars) xs
                     n = Term.nat (ann tm) (fromIntegral (length fvs))
-                    lam = addDelay $ Term.lam' (ann tm) fvs tm
+                    lam = addDelay $ Term.lam' (ann tm) ((Ann.GeneratedFrom spanAnn,) <$> fvs) tm
                  in Term.apps' f [n, lam]
               tm -> Term.apps' f [Term.nat (ann tm) 0, addDelay tm]
           "syntax.docTransclude" -> evalLike id
@@ -980,23 +984,24 @@ delayQuote :: (Monad m, Var v) => TermP v m
 delayQuote = P.label "quote" do
   start <- reserved "'"
   e <- termLeaf
-  pure $ DD.delayTerm (ann start <> ann e) e
+  pure $ DD.delayTerm (ann start <> ann e) (ann start) e
 
 delayBlock :: (Monad m, Var v) => P v m (Ann {- Ann spanning the whole block -}, Term v Ann)
 delayBlock = P.label "do" do
   (spanAnn, b) <- block "do"
-  pure $ (spanAnn, DD.delayTerm (ann b) b)
+  let argSpan = (ann b {- would be nice to use the annotation for 'do' here, but it's not terribly important -})
+  pure $ (spanAnn, DD.delayTerm (ann b) argSpan b)
 
 bang :: (Monad m, Var v) => TermP v m
 bang = P.label "bang" do
   start <- reserved "!"
   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 +1013,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
@@ -1134,7 +1139,8 @@ binding = label "binding" do
     mkBinding :: Ann -> [L.Token v] -> Term.Term v Ann -> Term.Term v Ann
     mkBinding _lhsLoc [] body = body
     mkBinding lhsLoc args body =
-      (Term.lam' (lhsLoc <> ann body) (L.payload <$> args) body)
+      let annotatedArgs = args <&> \arg -> (ann arg, L.payload arg)
+       in Term.lam' (lhsLoc <> ann body) annotatedArgs body
 
 customFailure :: (P.MonadParsec e s m) => e -> m a
 customFailure = P.customFailure

parser-typechecker/src/Unison/Syntax/TermPrinter.hs

@@ -1958,7 +1958,7 @@ toDocExample' suffix ppe (Apps' (Ref' r) [Nat' n, l@(LamsNamed' vs tm)])
   | nameEndsWith ppe suffix r,
     ABT.freeVars l == mempty,
     ok tm =
-      Just (lam' (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm)
+      Just (lamWithoutBindingAnns (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm)
   where
     ok (Apps' f _) = ABT.freeVars f == mempty
     ok tm = ABT.freeVars tm == mempty

parser-typechecker/src/Unison/Typechecker/Components.hs

@@ -78,18 +78,15 @@ 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
                   blockAnn
                   (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' ::

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,

unison-cli/src/Unison/CommandLine/DisplayValues.hs

@@ -178,12 +178,12 @@ displayPretty pped terms typeOf eval types tm = go tm
       DD.Doc2SpecialFormExample n (DD.Doc2Example vs body) ->
         P.backticked <$> displayTerm pped terms typeOf eval types ex
         where
-          ex = Term.lam' (ABT.annotation body) (drop (fromIntegral n) vs) body
+          ex = Term.lamWithoutBindingAnns (ABT.annotation body) (drop (fromIntegral n) vs) body
       DD.Doc2SpecialFormExampleBlock n (DD.Doc2Example vs body) ->
         -- todo: maybe do something with `vs` to indicate the variables are free
         P.indentN 4 <$> displayTerm' True pped terms typeOf eval types ex
         where
-          ex = Term.lam' (ABT.annotation body) (drop (fromIntegral n) vs) body
+          ex = Term.lamWithoutBindingAnns (ABT.annotation body) (drop (fromIntegral n) vs) body
 
       -- Link (Either Link.Type Doc2.Term)
       DD.Doc2SpecialFormLink e ->

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

unison-cli/src/Unison/LSP/FileAnalysis.hs

@@ -112,7 +112,7 @@ checkFile doc = runMaybeT do
           & toRangeMap
   let typeSignatureHints = fromMaybe mempty (mkTypeSignatureHints <$> parsedFile <*> typecheckedFile)
   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 ->
@@ -194,6 +194,7 @@ computeConflictWarningDiagnostics fileUri fileSummary@FileSummary {fileNames} =
                       fileUri
                       newRange
                       DiagnosticSeverity_Information
+                      []
                       msg
                       mempty
   pure $ toDiagnostics conflictedTermLocations <> toDiagnostics conflictedTypeLocations
@@ -280,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 ->
@@ -336,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

unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs

@@ -10,32 +10,26 @@ 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
+          -- 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
     getRelevantVarName = \case