diff --git a/.gitignore b/.gitignore index 8a2be67a49..594dc26eda 100644 --- a/.gitignore +++ b/.gitignore @@ -19,6 +19,9 @@ dist-newstyle # GHC *.hie *.prof +*.prof.html +*.profiterole.html +*.profiterole.txt /.direnv/ /.envrc diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 208478e66e..f6e8d42923 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -84,6 +84,7 @@ import Unison.DataDeclaration import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.KindInference qualified as KindInference +import Unison.Name (Name) import Unison.Pattern (Pattern) import Unison.Pattern qualified as Pattern import Unison.PatternMatchCoverage (checkMatch) @@ -104,7 +105,6 @@ import Unison.Typechecker.TypeLookup qualified as TL import Unison.Typechecker.TypeVar qualified as TypeVar import Unison.Var (Var) import Unison.Var qualified as Var -import Unison.Name (Name) type TypeVar v loc = TypeVar.TypeVar (B.Blank loc) v @@ -358,6 +358,12 @@ data InfoNote v loc = SolvedBlank (B.Recorded loc) v (Type v loc) | Decision v loc (Term.Term v loc) | TopLevelComponent [(v, Type.Type v loc, RedundantTypeAnnotation)] + | -- The inferred type of a let or argument binding, and the scope of that binding as a loc. + -- Note that if interpreting the type of a 'v' at a given usage site, it is the caller's + -- job to use the binding with the smallest containing scope so as to respect variable + -- shadowing. + -- This is used in the LSP. + VarBinding v loc (Type.Type v loc) deriving (Show) topLevelComponent :: (Var v) => [(v, Type.Type v loc, RedundantTypeAnnotation)] -> InfoNote v loc @@ -1085,7 +1091,7 @@ noteTopLevelType e binding typ = case binding of Term.Ann' strippedBinding _ -> do inferred <- (Just <$> synthesizeTop strippedBinding) `orElse` pure Nothing case inferred of - Nothing -> + Nothing -> do btw $ topLevelComponent [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, False)] @@ -1095,10 +1101,15 @@ noteTopLevelType e binding typ = case binding of topLevelComponent [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, redundant)] -- The signature didn't exist, so was definitely redundant - _ -> + _ -> do btw $ topLevelComponent [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, True)] +-- | Take note of the types and locations of all bindings, including let bindings, letrec +-- bindings, lambda argument bindings and top-level bindings. +-- This information is used to provide information to the LSP after typechecking. +noteVarBinding :: (Var v) => v -> loc -> Type.Type v loc -> M v loc () +noteVarBinding v span t = btw $ VarBinding v span t synthesizeTop :: (Var v) => @@ -1207,7 +1218,7 @@ synthesizeWanted (Term.Constructor' r) = synthesizeWanted tm@(Term.Request' r) = fmap (wantRequest tm) . ungeneralize . Type.purifyArrows =<< getEffectConstructorType r -synthesizeWanted (Term.Let1Top' top binding e) = do +synthesizeWanted abt@(Term.Let1Top' top binding e) = do (tbinding, wb) <- synthesizeBinding top binding v' <- ABT.freshen e freshenVar when (Var.isAction (ABT.variable e)) $ @@ -1216,14 +1227,15 @@ synthesizeWanted (Term.Let1Top' top binding e) = do appendContext [Ann v' tbinding] (t, w) <- synthesize (ABT.bindInheritAnnotation e (Term.var () v')) t <- applyM t - when top $ noteTopLevelType e binding tbinding + when top $ noteTopLevelType e binding tbinding + noteVarBinding (ABT.variable e) (ABT.annotation abt) (TypeVar.lowerType tbinding) want <- coalesceWanted w wb -- doRetract $ Ann v' tbinding pure (t, want) synthesizeWanted (Term.LetRecNamed' [] body) = synthesizeWanted body -synthesizeWanted (Term.LetRecTop' isTop letrec) = do +synthesizeWanted abt@(Term.LetRecTop' isTop letrec) = do ((t, want), ctx2) <- markThenRetract (Var.named "let-rec-marker") $ do - e <- annotateLetRecBindings isTop letrec + e <- annotateLetRecBindings (ABT.annotation abt) isTop letrec synthesize e want <- substAndDefaultWanted want ctx2 pure (generalizeExistentials ctx2 t, want) @@ -1325,6 +1337,9 @@ synthesizeWanted e else checkWithAbilities [et] body' ot ctx <- getContext let t = apply ctx $ Type.arrow l it (Type.effect l [et] ot) + + let solvedInputType = fromMaybe it . fmap Type.getPolytype $ Map.lookup i . solvedExistentials . info $ ctx + noteVarBinding i l (TypeVar.lowerType $ solvedInputType) pure (t, []) | Term.If' cond t f <- e = do cwant <- scope InIfCond $ check cond (Type.boolean l) @@ -1823,10 +1838,11 @@ resetContextAfter x a = do -- See usage in `synthesize` and `check` for `LetRec'` case. annotateLetRecBindings :: (Var v, Ord loc) => + loc -> Term.IsTop -> ((v -> M v loc v) -> M v loc ([(v, Term v loc)], Term v loc)) -> M v loc (Term v loc) -annotateLetRecBindings isTop letrec = +annotateLetRecBindings span isTop letrec = -- If this is a top-level letrec, then emit a TopLevelComponent note, -- which asks if the user-provided type annotations were needed. if isTop @@ -1850,8 +1866,10 @@ annotateLetRecBindings isTop letrec = btw $ topLevelComponent ((\(v, b) -> (Var.reset v, b, False)) . unTypeVar <$> vts) pure body - else -- If this isn't a top-level letrec, then we don't have to do anything special - fst <$> annotateLetRecBindings' True + else do -- If this isn't a top-level letrec, then we don't have to do anything special + (body, vts) <- annotateLetRecBindings' True + for_ vts \(v, t) -> noteVarBinding v span (TypeVar.lowerType t) + pure body where annotateLetRecBindings' useUserAnnotations = do (bindings, body) <- letrec freshenVar @@ -1894,6 +1912,9 @@ annotateLetRecBindings isTop letrec = gen bindingType _arity = generalizeExistentials ctx2 bindingType bindingTypesGeneralized = zipWith gen bindingTypes bindingArities annotations = zipWith Ann vs bindingTypesGeneralized + -- TODO: is this right? + for_ (zip3 vs bindings bindingTypesGeneralized) \(v, b, t) -> do + noteVarBinding v (loc b) (TypeVar.lowerType t) appendContext annotations pure (body, vs `zip` bindingTypesGeneralized) @@ -2197,7 +2218,7 @@ coalesceWanted' keep ((loc, n) : new) old if keep u then pure (new, (loc, n) : old) else do - defaultAbility n + _ <- defaultAbility n pure (new, old) coalesceWanted new old | otherwise = coalesceWanted' keep new ((loc, n) : old) @@ -2432,7 +2453,7 @@ checkWanted want (Term.Lam' body) (Type.Arrow'' i es o) = do body <- pure $ ABT.bindInheritAnnotation body (Term.var () x) checkWithAbilities es body o pure want -checkWanted want (Term.Let1Top' top binding m) t = do +checkWanted want abt@(Term.Let1Top' top binding m) t = do (tbinding, wbinding) <- synthesizeBinding top binding want <- coalesceWanted wbinding want v <- ABT.freshen m freshenVar @@ -2441,13 +2462,14 @@ checkWanted want (Term.Let1Top' top binding m) t = do -- enforce that actions in a block have type () subtype tbinding (DDB.unitType (ABT.annotation binding)) extendContext (Ann v tbinding) + noteVarBinding v (ABT.annotation abt) (TypeVar.lowerType tbinding) checkWanted want (ABT.bindInheritAnnotation m (Term.var () v)) t checkWanted want (Term.LetRecNamed' [] m) t = checkWanted want m t -- letrec can't have effects, so it doesn't extend the wanted set -checkWanted want (Term.LetRecTop' isTop lr) t = +checkWanted want abt@(Term.LetRecTop' isTop lr) t = markThenRetractWanted (Var.named "let-rec-marker") $ do - e <- annotateLetRecBindings isTop lr + e <- annotateLetRecBindings (ABT.annotation abt) isTop lr checkWanted want e t checkWanted want e@(Term.Match' scrut cases) t = do (scrutType, swant) <- synthesize scrut diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index f5f29b5e27..2c64fcd096 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -7,6 +7,7 @@ import Control.Monad.Reader import Crypto.Random qualified as Random import Data.Align (alignWith) import Data.Foldable +import Data.Foldable qualified as Foldable import Data.IntervalMap.Lazy (IntervalMap) import Data.IntervalMap.Lazy qualified as IM import Data.Map qualified as Map @@ -23,6 +24,7 @@ import Language.LSP.Protocol.Types TextDocumentIdentifier (TextDocumentIdentifier), Uri (getUri), ) +import Language.LSP.Protocol.Types qualified as LSP import Unison.ABT qualified as ABT import Unison.Cli.TypeCheck (computeTypecheckingEnvironment) import Unison.Cli.UniqueTypeGuidLookup qualified as Cli @@ -37,6 +39,7 @@ import Unison.LSP.Conversions qualified as Cv import Unison.LSP.Diagnostics (DiagnosticSeverity (..), mkDiagnostic, reportDiagnostics) import Unison.LSP.Orphans () import Unison.LSP.Types +import Unison.LSP.Util.IntersectionMap (keyedSingleton) import Unison.LSP.VFS qualified as VFS import Unison.Name (Name) import Unison.Names (Names) @@ -55,6 +58,7 @@ import Unison.Referent qualified as Referent import Unison.Result (Note) import Unison.Result qualified as Result import Unison.Symbol (Symbol) +import Unison.Symbol qualified as Symbol import Unison.Syntax.HashQualified' qualified as HQ' (toText) import Unison.Syntax.Lexer qualified as L import Unison.Syntax.Name qualified as Name @@ -93,16 +97,29 @@ checkFile doc = runMaybeT do uniqueTypeGuid = Cli.loadUniqueTypeGuid currentPath, names = parseNames } - (notes, parsedFile, typecheckedFile) <- do + (localBindingTypes, notes, parsedFile, typecheckedFile) <- do liftIO do Codebase.runTransaction cb do parseResult <- Parsers.parseFile (Text.unpack sourceName) (Text.unpack srcText) parsingEnv case Result.fromParsing parseResult of - Result.Result parsingNotes Nothing -> pure (parsingNotes, Nothing, Nothing) + Result.Result parsingNotes Nothing -> pure (mempty, parsingNotes, Nothing, Nothing) Result.Result _ (Just parsedFile) -> do typecheckingEnv <- computeTypecheckingEnvironment (ShouldUseTndr'Yes parsingEnv) cb ambientAbilities parsedFile let Result.Result typecheckingNotes maybeTypecheckedFile = FileParsers.synthesizeFile typecheckingEnv parsedFile - pure (typecheckingNotes, Just parsedFile, maybeTypecheckedFile) + localBindings <- + typecheckingNotes + & Foldable.toList + & reverse -- Type notes that come later in typechecking have more information filled in. + & foldMap \case + Result.TypeInfo (Context.VarBinding (Symbol.Symbol _ (Var.User v)) loc typ) -> + Cv.annToRange loc & foldMap (\(LSP.Range start end) -> (keyedSingleton v (start, end) typ)) + _ -> mempty + & pure + pure (localBindings, typecheckingNotes, Just parsedFile, maybeTypecheckedFile) + + Debug.debugM Debug.Temp "BEFORE Local Bindings" () + Debug.debugM Debug.Temp "My Local Bindings" localBindingTypes + Debug.debugM Debug.Temp "AFTER Local Bindings" () filePPED <- lift $ ppedForFileHelper parsedFile typecheckedFile (errDiagnostics, codeActions) <- lift $ analyseFile fileUri srcText filePPED notes let codeActionRanges = @@ -207,106 +224,107 @@ getTokenMap tokens = analyseNotes :: (Foldable f) => Uri -> PrettyPrintEnv -> String -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction]) analyseNotes fileUri ppe src notes = do - flip foldMapM notes \note -> case note of - Result.TypeError errNote@(Context.ErrorNote {cause}) -> do - let typeErr = TypeError.typeErrorFromNote errNote - ranges = case typeErr of - TypeError.Mismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite - TypeError.BooleanMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite - TypeError.ExistentialMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite - TypeError.FunctionApplication {f} -> singleRange $ ABT.annotation f - TypeError.NotFunctionApplication {f} -> singleRange $ ABT.annotation f - TypeError.AbilityCheckFailure {abilityCheckFailureSite} -> singleRange abilityCheckFailureSite - TypeError.AbilityEqFailure {abilityCheckFailureSite} -> singleRange abilityCheckFailureSite - TypeError.AbilityEqFailureFromAp {expectedSite, mismatchSite} -> do - let locs = [ABT.annotation expectedSite, ABT.annotation mismatchSite] - (r, rs) <- withNeighbours (locs >>= aToR) - pure (r, ("mismatch",) <$> rs) - TypeError.UnguardedLetRecCycle {cycleLocs} -> do - let ranges :: [Range] - ranges = cycleLocs >>= aToR - (range, cycleRanges) <- withNeighbours ranges - pure (range, ("cycle",) <$> cycleRanges) - TypeError.UnknownType {typeSite} -> singleRange typeSite - TypeError.UnknownTerm {termSite} -> singleRange termSite - TypeError.DuplicateDefinitions {defns} -> do - (_v, locs) <- toList defns - (r, rs) <- withNeighbours (locs >>= aToR) - pure (r, ("duplicate definition",) <$> rs) - TypeError.RedundantPattern loc -> singleRange loc - TypeError.UncoveredPatterns loc _pats -> singleRange loc - TypeError.KindInferenceFailure ke -> singleRange (KindInference.lspLoc ke) - -- These type errors don't have custom type error conversions, but some - -- still have valid diagnostics. - TypeError.Other e@(Context.ErrorNote {cause}) -> case cause of - Context.PatternArityMismatch loc _typ _numArgs -> singleRange loc - Context.HandlerOfUnexpectedType loc _typ -> singleRange loc - Context.TypeMismatch {} -> shouldHaveBeenHandled e - Context.IllFormedType {} -> shouldHaveBeenHandled e - Context.UnknownSymbol loc _ -> singleRange loc - Context.UnknownTerm loc _ _ _ -> singleRange loc - Context.AbilityCheckFailure {} -> shouldHaveBeenHandled e - Context.AbilityEqFailure {} -> shouldHaveBeenHandled e - Context.EffectConstructorWrongArgCount {} -> shouldHaveBeenHandled e - Context.MalformedEffectBind {} -> shouldHaveBeenHandled e - Context.DuplicateDefinitions {} -> shouldHaveBeenHandled e - Context.UnguardedLetRecCycle {} -> shouldHaveBeenHandled e - Context.ConcatPatternWithoutConstantLength loc _ -> singleRange loc - Context.DataEffectMismatch _ _ decl -> singleRange $ DD.annotation decl - Context.UncoveredPatterns loc _ -> singleRange loc - Context.RedundantPattern loc -> singleRange loc - Context.InaccessiblePattern loc -> singleRange loc - Context.KindInferenceFailure {} -> shouldHaveBeenHandled e - shouldHaveBeenHandled e = do - Debug.debugM Debug.LSP "This diagnostic should have been handled by a previous case but was not" e - empty - diags = noteDiagnostic note ranges - -- Sort on match accuracy first, then name. - codeActions <- case cause of - Context.UnknownTerm _ v suggestions typ -> do - typeHoleActions <- typeHoleReplacementCodeActions diags v typ - pure $ - nameResolutionCodeActions diags suggestions - <> typeHoleActions - _ -> pure [] - pure (diags, codeActions) - Result.NameResolutionFailures {} -> do - -- TODO: diagnostics/code actions for resolution failures - pure (noteDiagnostic note todoAnnotation, []) - Result.Parsing err -> do - let diags = 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 [] - -- TODO: Some parsing errors likely have reasonable code actions - pure (diags, []) - Result.UnknownSymbol _ loc -> - pure (noteDiagnostic note (singleRange loc), []) - Result.TypeInfo {} -> - -- No relevant diagnostics from type info. - pure ([], []) - Result.CompilerBug cbug -> do - let ranges = case cbug of - Result.TopLevelComponentNotFound _ trm -> singleRange $ ABT.annotation trm - Result.ResolvedNameNotFound _ loc _ -> singleRange loc - Result.TypecheckerBug tcbug -> case tcbug of - Context.UnknownDecl _un _ref decls -> decls & foldMap \decl -> singleRange $ DD.annotation decl - Context.UnknownConstructor _un _gcr decl -> singleRange $ DD.annotation decl - Context.UndeclaredTermVariable _sym _con -> todoAnnotation - Context.RetractFailure _el _con -> todoAnnotation - Context.EmptyLetRec trm -> singleRange $ ABT.annotation trm - Context.PatternMatchFailure -> todoAnnotation - Context.EffectConstructorHadMultipleEffects typ -> singleRange $ ABT.annotation typ - Context.FreeVarsInTypeAnnotation _set -> todoAnnotation - Context.UnannotatedReference _ref -> todoAnnotation - Context.MalformedPattern pat -> singleRange $ Pattern.loc pat - Context.UnknownTermReference _ref -> todoAnnotation - Context.UnknownExistentialVariable _sym _con -> todoAnnotation - Context.IllegalContextExtension _con _el _s -> todoAnnotation - Context.OtherBug _s -> todoAnnotation - pure (noteDiagnostic note ranges, []) + foldMapM go notes where + go :: Note Symbol Ann -> Lsp ([Diagnostic], [RangedCodeAction]) + go note = case note of + Result.TypeError errNote@(Context.ErrorNote {cause}) -> do + let typeErr = TypeError.typeErrorFromNote errNote + ranges = case typeErr of + TypeError.Mismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite + TypeError.BooleanMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite + TypeError.ExistentialMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite + TypeError.FunctionApplication {f} -> singleRange $ ABT.annotation f + TypeError.NotFunctionApplication {f} -> singleRange $ ABT.annotation f + TypeError.AbilityCheckFailure {abilityCheckFailureSite} -> singleRange abilityCheckFailureSite + TypeError.AbilityEqFailure {abilityCheckFailureSite} -> singleRange abilityCheckFailureSite + TypeError.AbilityEqFailureFromAp {expectedSite, mismatchSite} -> do + let locs = [ABT.annotation expectedSite, ABT.annotation mismatchSite] + (r, rs) <- withNeighbours (locs >>= aToR) + pure (r, ("mismatch",) <$> rs) + TypeError.UnguardedLetRecCycle {cycleLocs} -> do + let ranges :: [Range] + ranges = cycleLocs >>= aToR + (range, cycleRanges) <- withNeighbours ranges + pure (range, ("cycle",) <$> cycleRanges) + TypeError.UnknownType {typeSite} -> singleRange typeSite + TypeError.UnknownTerm {termSite} -> singleRange termSite + TypeError.DuplicateDefinitions {defns} -> do + (_v, locs) <- toList defns + (r, rs) <- withNeighbours (locs >>= aToR) + pure (r, ("duplicate definition",) <$> rs) + TypeError.RedundantPattern loc -> singleRange loc + TypeError.UncoveredPatterns loc _pats -> singleRange loc + TypeError.KindInferenceFailure ke -> singleRange (KindInference.lspLoc ke) + -- These type errors don't have custom type error conversions, but some + -- still have valid diagnostics. + TypeError.Other e@(Context.ErrorNote {cause}) -> case cause of + Context.PatternArityMismatch loc _typ _numArgs -> singleRange loc + Context.HandlerOfUnexpectedType loc _typ -> singleRange loc + Context.TypeMismatch {} -> shouldHaveBeenHandled e + Context.IllFormedType {} -> shouldHaveBeenHandled e + Context.UnknownSymbol loc _ -> singleRange loc + Context.UnknownTerm loc _ _ _ -> singleRange loc + Context.AbilityCheckFailure {} -> shouldHaveBeenHandled e + Context.AbilityEqFailure {} -> shouldHaveBeenHandled e + Context.EffectConstructorWrongArgCount {} -> shouldHaveBeenHandled e + Context.MalformedEffectBind {} -> shouldHaveBeenHandled e + Context.DuplicateDefinitions {} -> shouldHaveBeenHandled e + Context.UnguardedLetRecCycle {} -> shouldHaveBeenHandled e + Context.ConcatPatternWithoutConstantLength loc _ -> singleRange loc + Context.DataEffectMismatch _ _ decl -> singleRange $ DD.annotation decl + Context.UncoveredPatterns loc _ -> singleRange loc + Context.RedundantPattern loc -> singleRange loc + Context.InaccessiblePattern loc -> singleRange loc + Context.KindInferenceFailure {} -> shouldHaveBeenHandled e + shouldHaveBeenHandled e = do + Debug.debugM Debug.LSP "This diagnostic should have been handled by a previous case but was not" e + empty + diags = noteDiagnostic note ranges + -- Sort on match accuracy first, then name. + codeActions <- case cause of + Context.UnknownTerm _ v suggestions typ -> do + typeHoleActions <- typeHoleReplacementCodeActions diags v typ + pure $ + nameResolutionCodeActions diags suggestions + <> typeHoleActions + _ -> pure [] + pure (diags, codeActions) + Result.NameResolutionFailures {} -> do + -- TODO: diagnostics/code actions for resolution failures + pure (noteDiagnostic note todoAnnotation, []) + Result.Parsing err -> do + let diags = 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 [] + -- TODO: Some parsing errors likely have reasonable code actions + pure (diags, []) + Result.UnknownSymbol _ loc -> + pure (noteDiagnostic note (singleRange loc), []) + Result.TypeInfo {} -> pure ([], []) + Result.CompilerBug cbug -> do + let ranges = case cbug of + Result.TopLevelComponentNotFound _ trm -> singleRange $ ABT.annotation trm + Result.ResolvedNameNotFound _ loc _ -> singleRange loc + Result.TypecheckerBug tcbug -> case tcbug of + Context.UnknownDecl _un _ref decls -> decls & foldMap \decl -> singleRange $ DD.annotation decl + Context.UnknownConstructor _un _gcr decl -> singleRange $ DD.annotation decl + Context.UndeclaredTermVariable _sym _con -> todoAnnotation + Context.RetractFailure _el _con -> todoAnnotation + Context.EmptyLetRec trm -> singleRange $ ABT.annotation trm + Context.PatternMatchFailure -> todoAnnotation + Context.EffectConstructorHadMultipleEffects typ -> singleRange $ ABT.annotation typ + Context.FreeVarsInTypeAnnotation _set -> todoAnnotation + Context.UnannotatedReference _ref -> todoAnnotation + Context.MalformedPattern pat -> singleRange $ Pattern.loc pat + Context.UnknownTermReference _ref -> todoAnnotation + Context.UnknownExistentialVariable _sym _con -> todoAnnotation + Context.IllegalContextExtension _con _el _s -> todoAnnotation + Context.OtherBug _s -> todoAnnotation + pure (noteDiagnostic note ranges, []) + -- Diagnostics with this return value haven't been properly configured yet. todoAnnotation = [] singleRange :: Ann -> [(Range, [a])] diff --git a/unison-cli/src/Unison/LSP/Hover.hs b/unison-cli/src/Unison/LSP/Hover.hs index aa6e6b7cf3..92c30cf159 100644 --- a/unison-cli/src/Unison/LSP/Hover.hs +++ b/unison-cli/src/Unison/LSP/Hover.hs @@ -10,10 +10,13 @@ import Language.LSP.Protocol.Lens import Language.LSP.Protocol.Message qualified as Msg import Language.LSP.Protocol.Types import Unison.ABT qualified as ABT +import Unison.Debug qualified as Debug import Unison.HashQualified qualified as HQ import Unison.LSP.FileAnalysis (ppedForFile) +import Unison.LSP.FileAnalysis qualified as FileAnalysis import Unison.LSP.Queries qualified as LSPQ import Unison.LSP.Types +import Unison.LSP.Util.IntersectionMap qualified as IM import Unison.LSP.VFS qualified as VFS import Unison.LabeledDependency qualified as LD import Unison.Parser.Ann (Ann) @@ -24,18 +27,18 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference qualified as Reference import Unison.Runtime.IOSource qualified as IOSource import Unison.Symbol (Symbol) +import Unison.Symbol qualified as Symbol import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.Name qualified as Name import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Term qualified as Term +import Unison.Type qualified as Type import Unison.Util.Pretty qualified as Pretty +import Unison.Var (Var) +import Unison.Var qualified as Var import UnliftIO qualified -- | Hover help handler --- --- TODO: --- * Add docs --- * Resolve fqn on hover hoverHandler :: Msg.TRequestMessage 'Msg.Method_TextDocumentHover -> (Either Msg.ResponseError (Msg.MessageResult 'Msg.Method_TextDocumentHover) -> Lsp ()) -> Lsp () hoverHandler m respond = do respond . Right . maybe (InR Null) InL =<< runMaybeT do @@ -49,7 +52,7 @@ hoverHandler m respond = do hoverInfo :: Uri -> Position -> MaybeT Lsp Text hoverInfo uri pos = - (hoverInfoForRef <|> hoverInfoForLiteral) + (hoverInfoForRef <|> hoverInfoForLiteral <|> hoverInfoForLocalVar) where markdownify :: Text -> Text markdownify rendered = Text.unlines ["```unison", rendered, "```"] @@ -100,9 +103,14 @@ hoverInfo uri pos = pure typ LD.TermReferent ref -> do typ <- LSPQ.getTypeOfReferent uri ref - let renderedType = Text.pack $ TypePrinter.prettyStr (Just prettyWidth) (PPED.suffixifiedPPE pped) typ - pure (symAtCursor <> " : " <> renderedType) + pure $ renderTypeSigForHover pped symAtCursor typ pure . Text.unlines $ [markdownify typeSig] <> renderedDocs + + renderTypeSigForHover :: Var v => PPED.PrettyPrintEnvDecl -> Text -> Type.Type v a -> Text + renderTypeSigForHover pped name typ = + let renderedType = Text.pack $ TypePrinter.prettyStr (Just prettyWidth) (PPED.suffixifiedPPE pped) typ + in (name <> " : " <> renderedType) + hoverInfoForLiteral :: MaybeT Lsp Text hoverInfoForLiteral = markdownify <$> do @@ -115,6 +123,26 @@ hoverInfo uri pos = typ <- hoistMaybe $ builtinTypeForPatternLiterals pat pure (": " <> typ) + hoverInfoForLocalVar :: MaybeT Lsp Text + hoverInfoForLocalVar = do + let varFromNode = do + node <- LSPQ.nodeAtPosition uri pos + Debug.debugM Debug.Temp "node" node + case node of + LSPQ.TermNode (Term.Var' (Symbol.Symbol _ (Var.User v))) -> pure $ v + LSPQ.TermNode {} -> empty + LSPQ.TypeNode {} -> empty + LSPQ.PatternNode _pat -> empty + let varFromText = VFS.identifierAtPosition uri pos + localVar <- varFromNode <|> varFromText + Debug.debugM Debug.Temp "localVar" localVar + FileAnalysis {localBindingTypes} <- FileAnalysis.getFileAnalysis uri + Debug.debugM Debug.Temp "pos" pos + Debug.debugM Debug.Temp "localBindingTypes" localBindingTypes + (_range, typ) <- hoistMaybe $ IM.keyedSmallestIntersection localVar pos localBindingTypes + pped <- lift $ ppedForFile uri + pure $ renderTypeSigForHover pped localVar typ + hoistMaybe :: Maybe a -> MaybeT Lsp a hoistMaybe = MaybeT . pure diff --git a/unison-cli/src/Unison/LSP/Types.hs b/unison-cli/src/Unison/LSP/Types.hs index c5fe0e9a95..5458df3c27 100644 --- a/unison-cli/src/Unison/LSP/Types.hs +++ b/unison-cli/src/Unison/LSP/Types.hs @@ -28,6 +28,7 @@ import Unison.Codebase.Path qualified as Path import Unison.Codebase.Runtime (Runtime) import Unison.Debug qualified as Debug import Unison.LSP.Orphans () +import Unison.LSP.Util.IntersectionMap (KeyedIntersectionMap) import Unison.LabeledDependency (LabeledDependency) import Unison.Name (Name) import Unison.NameSegment (NameSegment) @@ -124,6 +125,11 @@ data FileAnalysis = FileAnalysis notes :: Seq (Note Symbol Ann), diagnostics :: IntervalMap Position [Diagnostic], codeActions :: IntervalMap Position [CodeAction], + -- | The types of local variable bindings keyed by the span that they're valid. + -- There may be many mentions of the same symbol in the file, and their may be several + -- bindings which shadow each other, use this map to find the smallest spanning position + -- which contains the symbol you're interested in. + localBindingTypes :: KeyedIntersectionMap Text Position (Type Symbol Ann), typeSignatureHints :: Map Symbol TypeSignatureHint, fileSummary :: Maybe FileSummary } diff --git a/unison-cli/src/Unison/LSP/Util/IntersectionMap.hs b/unison-cli/src/Unison/LSP/Util/IntersectionMap.hs new file mode 100644 index 0000000000..6122b7a6e4 --- /dev/null +++ b/unison-cli/src/Unison/LSP/Util/IntersectionMap.hs @@ -0,0 +1,111 @@ +module Unison.LSP.Util.IntersectionMap + ( -- * Intersection map + intersectionsFromList, + intersectionsSingleton, + IntersectionRange (..), + IntersectionMap, + smallestIntersection, + + -- * Keyed intersection map + KeyedIntersectionMap, + keyedFromList, + keyedSingleton, + keyedSmallestIntersection, + ) +where + +import Data.List qualified as List +import Data.Map qualified as Map +import Language.LSP.Protocol.Types qualified as LSP +import Unison.Prelude +import Unison.Util.List (safeHead) + +-- | An intersection map where intersections are partitioned by a key. +newtype KeyedIntersectionMap k pos a = KeyedIntersectionMap (Map k (IntersectionMap pos a)) + deriving stock (Show, Eq) + +instance (Ord k, Ord pos) => Semigroup (KeyedIntersectionMap k pos a) where + KeyedIntersectionMap a <> KeyedIntersectionMap b = KeyedIntersectionMap (Map.unionWith (<>) a b) + +instance (Ord k, Ord pos) => Monoid (KeyedIntersectionMap k pos a) where + mempty = KeyedIntersectionMap Map.empty + +keyedFromList :: (Ord k, IntersectionRange pos) => [(k, ((pos, pos), a))] -> KeyedIntersectionMap k pos a +keyedFromList elems = + KeyedIntersectionMap $ + elems + & fmap (\(k, (range, v)) -> (k, intersectionsSingleton range v)) + & Map.fromListWith (<>) + +keyedSingleton :: (Ord k, IntersectionRange pos) => k -> (pos, pos) -> a -> KeyedIntersectionMap k pos a +keyedSingleton k range a = keyedFromList [(k, (range, a))] + +-- | NOTE: Assumes that ranges only NEST and never overlap, which is an invariant that should +-- be maintained by the ABT annotations. +-- +-- Returns the value associated with the tightest span which intersects with the given position. +keyedSmallestIntersection :: (Ord k, IntersectionRange pos) => k -> pos -> KeyedIntersectionMap k pos a -> Maybe ((pos, pos), a) +keyedSmallestIntersection k p (KeyedIntersectionMap m) = do + intersections <- Map.lookup k m + smallestIntersection p intersections + +newtype IntersectionMap pos a = IntersectionMap (Map (pos, pos) a) + deriving stock (Show, Eq) + +instance (Ord pos) => Semigroup (IntersectionMap pos a) where + IntersectionMap a <> IntersectionMap b = IntersectionMap (a <> b) + +instance (Ord pos) => Monoid (IntersectionMap pos a) where + mempty = IntersectionMap mempty + +-- | Class for types that can be used as ranges for intersection maps. +class Ord pos => IntersectionRange pos where + intersects :: pos -> (pos, pos) -> Bool + + -- Returns true if the first bound is tighter than the second. + isTighterThan :: (pos, pos) -> (pos, pos) -> Bool + +instance IntersectionRange LSP.Position where + intersects (LSP.Position l c) ((LSP.Position lStart cStart), (LSP.Position lEnd cEnd)) = + (l >= lStart && l <= lEnd) + && if + | l == lStart && l == lEnd -> c >= cStart && c <= cEnd + | l == lStart -> c >= cStart + | l == lEnd -> c <= cEnd + | otherwise -> True + + ((LSP.Position lStartA cStartA), (LSP.Position lEndA cEndA)) `isTighterThan` ((LSP.Position lStartB cStartB), (LSP.Position lEndB cEndB)) = + if lStartA == lStartB && lEndA == lEndB + then cStartA >= cStartB && cEndA <= cEndB + else lStartA >= lStartB && lEndA <= lEndB + +-- | Construct an intersection map from a list of ranges and values. +-- Duplicates are dropped. +intersectionsFromList :: (Ord pos) => [((pos, pos), a)] -> IntersectionMap pos a +intersectionsFromList elems = + IntersectionMap $ Map.fromList elems + +intersectionsSingleton :: (pos, pos) -> a -> IntersectionMap pos a +intersectionsSingleton range a = IntersectionMap $ Map.singleton range a + +-- | NOTE: Assumes that ranges only NEST and never overlap, which is an invariant that should +-- be maintained by the ABT annotations. +-- +-- Returns the value associated with the tightest span which intersects with the given position. +-- +-- >>> smallestIntersection (LSP.Position 5 1) (intersectionsFromList [((LSP.Position 1 1, LSP.Position 3 1), "a"), ((LSP.Position 2 1, LSP.Position 8 1), "b"), ((LSP.Position 4 1, LSP.Position 6 1), "c")]) +-- Just ((Position {_line = 4, _character = 1},Position {_line = 6, _character = 1}),"c") +-- >>> smallestIntersection (LSP.Position 5 3) (intersectionsFromList [((LSP.Position 1 1, LSP.Position 3 1), "a"), ((LSP.Position 4 2, LSP.Position 6 5), "b"), ((LSP.Position 4 1, LSP.Position 6 6), "c"), ((LSP.Position 7 1, LSP.Position 9 1), "d")]) +-- Just ((Position {_line = 4, _character = 2},Position {_line = 6, _character = 5}),"b") +smallestIntersection :: IntersectionRange pos => pos -> IntersectionMap pos a -> Maybe ((pos, pos), a) +smallestIntersection p (IntersectionMap bounds) = + bounds + & Map.filterWithKey (\b _ -> p `intersects` b) + & Map.toList + & List.sortBy cmp + & safeHead + where + cmp (a, _) (b, _) = + if a `isTighterThan` b + then LT + else GT diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 6923ab417a..8ea0bf9f02 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack @@ -132,6 +132,7 @@ library Unison.LSP.Queries Unison.LSP.Types Unison.LSP.UCMWorker + Unison.LSP.Util.IntersectionMap Unison.LSP.VFS Unison.Main Unison.Share.Codeserver