From 59914f4ae1b5a068fbfcdf65260e733e743134d9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 May 2024 15:06:09 -0700 Subject: [PATCH 01/11] Initial local var notes working --- .../src/Unison/Typechecker/Context.hs | 65 ++++++++++++------- unison-cli/src/Unison/LSP/FileAnalysis.hs | 5 +- 2 files changed, 45 insertions(+), 25 deletions(-) diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 208478e66e..83187a0a80 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,11 @@ 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 local 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. + LetBinding v loc (Type.Type v loc) RedundantTypeAnnotation deriving (Show) topLevelComponent :: (Var v) => [(v, Type.Type v loc, RedundantTypeAnnotation)] -> InfoNote v loc @@ -474,6 +479,7 @@ scope :: PathElement v loc -> M v loc a -> M v loc a scope p (MT m) = MT \ppe pmcSwitch datas effects env -> mapErrors (scope' p) (m ppe pmcSwitch datas effects env) newtype Context v loc = Context [(Element v loc, Info v loc)] + deriving stock (Show) data Info v loc = Info { existentialVars :: Set v, -- set of existentials seen so far @@ -482,6 +488,7 @@ data Info v loc = Info termVarAnnotations :: Map v (Type v loc), allVars :: Set v -- all variables seen so far } + deriving stock (Show) -- | The empty context context0 :: Context v loc @@ -1075,30 +1082,38 @@ generalizeExistentials' t = isExistential TypeVar.Existential {} = True isExistential _ = False -noteTopLevelType :: +noteBindingType :: + forall v loc f a. (Ord loc, Var v) => + Term.IsTop -> ABT.Subst f v a -> Term v loc -> Type v loc -> M v loc () -noteTopLevelType e binding typ = case binding of +noteBindingType top e binding typ = case binding of Term.Ann' strippedBinding _ -> do inferred <- (Just <$> synthesizeTop strippedBinding) `orElse` pure Nothing case inferred of - Nothing -> - btw $ - topLevelComponent - [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, False)] + Nothing -> do + let v = Var.reset (ABT.variable e) + let t = generalizeAndUnTypeVar typ + let redundant = False + note [(v, t, redundant)] Just inferred -> do redundant <- isRedundant typ inferred - btw $ - topLevelComponent - [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, redundant)] + note [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, redundant)] -- The signature didn't exist, so was definitely redundant _ -> - btw $ - topLevelComponent - [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, True)] + note + [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, True)] + where + span :: loc + span = ABT.annotation binding + note :: (Var v) => [(v, Type.Type v loc, RedundantTypeAnnotation)] -> M v loc () + note infos = + if top + then btw $ topLevelComponent infos + else for_ infos \(v, t, r) -> btw $ LetBinding v span t r synthesizeTop :: (Var v) => @@ -1216,7 +1231,7 @@ 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 + noteBindingType top e binding tbinding want <- coalesceWanted w wb -- doRetract $ Ann v' tbinding pure (t, want) @@ -1313,6 +1328,7 @@ synthesizeWanted e let it = existential' l B.Blank i ot = existential' l B.Blank o et = existential' l B.Blank e + appendContext $ [existential i, existential e, existential o, Ann arg it] when (Var.typeOf i == Var.Delay) $ do @@ -1876,7 +1892,8 @@ annotateLetRecBindings isTop letrec = -- Anything else, just make up a fresh existential -- which will be refined during typechecking of the binding vt <- extendExistential v - pure $ (e, existential' (loc binding) B.Blank vt) + let typ = existential' (loc binding) B.Blank vt + pure $ (e, typ) (bindings, bindingTypes) <- unzip <$> traverse f bindings appendContext (zipWith Ann vs bindingTypes) -- check each `bi` against its type @@ -3379,15 +3396,15 @@ instance (Var v) => Show (Element v loc) where ++ TP.prettyStr Nothing PPE.empty t show (Marker v) = "|" ++ Text.unpack (Var.name v) ++ "|" -instance (Ord loc, Var v) => Show (Context v loc) where - show ctx@(Context es) = "Γ\n " ++ (intercalate "\n " . map (showElem ctx . fst)) (reverse es) - where - showElem _ctx (Var v) = case v of - TypeVar.Universal x -> "@" <> show x - e -> show e - showElem ctx (Solved _ v (Type.Monotype t)) = "'" ++ Text.unpack (Var.name v) ++ " = " ++ TP.prettyStr Nothing PPE.empty (apply ctx t) - showElem ctx (Ann v t) = Text.unpack (Var.name v) ++ " : " ++ TP.prettyStr Nothing PPE.empty (apply ctx t) - showElem _ (Marker v) = "|" ++ Text.unpack (Var.name v) ++ "|" +-- instance (Ord loc, Var v) => Show (Context v loc) where +-- show ctx@(Context es) = "Γ\n " ++ (intercalate "\n " . map (showElem ctx . fst)) (reverse es) +-- where +-- showElem _ctx (Var v) = case v of +-- TypeVar.Universal x -> "@" <> show x +-- e -> show e +-- showElem ctx (Solved _ v (Type.Monotype t)) = "'" ++ Text.unpack (Var.name v) ++ " = " ++ TP.prettyStr Nothing PPE.empty (apply ctx t) +-- showElem ctx (Ann v t) = Text.unpack (Var.name v) ++ " : " ++ TP.prettyStr Nothing PPE.empty (apply ctx t) +-- showElem _ (Marker v) = "|" ++ Text.unpack (Var.name v) ++ "|" instance (Monad f) => Monad (MT v loc f) where return = pure diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index f5f29b5e27..5d0f8390ef 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -283,7 +283,10 @@ analyseNotes fileUri ppe src notes = do pure (diags, []) Result.UnknownSymbol _ loc -> pure (noteDiagnostic note (singleRange loc), []) - Result.TypeInfo {} -> + Result.TypeInfo info -> do + case info of + Context.LetBinding v _loc typ _r -> Debug.debugM Debug.Temp "TypeInfo note" (v, typ) + _ -> pure () -- No relevant diagnostics from type info. pure ([], []) Result.CompilerBug cbug -> do From ce231b4aafd225d7777f8a8df378f172734c0c8c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 May 2024 15:56:42 -0700 Subject: [PATCH 02/11] First pass at local var binding type --- .../src/Unison/Typechecker/Context.hs | 9 ++--- unison-cli/package.yaml | 1 + unison-cli/src/Unison/LSP/FileAnalysis.hs | 33 +++++++++------- unison-cli/src/Unison/LSP/Hover.hs | 38 +++++++++++++++---- unison-cli/src/Unison/LSP/Types.hs | 6 +++ unison-cli/unison-cli.cabal | 5 ++- 6 files changed, 65 insertions(+), 27 deletions(-) diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 83187a0a80..282dd790bf 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -1086,11 +1086,12 @@ noteBindingType :: forall v loc f a. (Ord loc, Var v) => Term.IsTop -> + loc -> ABT.Subst f v a -> Term v loc -> Type v loc -> M v loc () -noteBindingType top e binding typ = case binding of +noteBindingType top span e binding typ = case binding of Term.Ann' strippedBinding _ -> do inferred <- (Just <$> synthesizeTop strippedBinding) `orElse` pure Nothing case inferred of @@ -1107,8 +1108,6 @@ noteBindingType top e binding typ = case binding of note [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, True)] where - span :: loc - span = ABT.annotation binding note :: (Var v) => [(v, Type.Type v loc, RedundantTypeAnnotation)] -> M v loc () note infos = if top @@ -1222,7 +1221,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)) $ @@ -1231,7 +1230,7 @@ synthesizeWanted (Term.Let1Top' top binding e) = do appendContext [Ann v' tbinding] (t, w) <- synthesize (ABT.bindInheritAnnotation e (Term.var () v')) t <- applyM t - noteBindingType top e binding tbinding + noteBindingType top (ABT.annotation abt) e binding tbinding want <- coalesceWanted w wb -- doRetract $ Ann v' tbinding pure (t, want) diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 3402e98c92..1862da26a6 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -48,6 +48,7 @@ dependencies: - lsp-types >= 2.0.2.0 - megaparsec - memory + - monoidal-containers - mtl - network - network-simple diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index 5d0f8390ef..59d5c1491c 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -9,7 +9,10 @@ import Data.Align (alignWith) import Data.Foldable import Data.IntervalMap.Lazy (IntervalMap) import Data.IntervalMap.Lazy qualified as IM +import Data.IntervalMap.Lazy qualified as IntervalMap import Data.Map qualified as Map +import Data.Map.Monoidal (MonoidalMap) +import Data.Map.Monoidal qualified as MonMap import Data.Set qualified as Set import Data.Text qualified as Text import Data.These @@ -61,6 +64,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.Type qualified as Type import Unison.Typechecker.Context qualified as Context import Unison.Typechecker.TypeError qualified as TypeError import Unison.UnisonFile qualified as UF @@ -104,7 +108,8 @@ checkFile doc = runMaybeT do let Result.Result typecheckingNotes maybeTypecheckedFile = FileParsers.synthesizeFile typecheckingEnv parsedFile pure (typecheckingNotes, Just parsedFile, maybeTypecheckedFile) filePPED <- lift $ ppedForFileHelper parsedFile typecheckedFile - (errDiagnostics, codeActions) <- lift $ analyseFile fileUri srcText filePPED notes + (errDiagnostics, codeActions, localBindingTypes) <- lift $ analyseFile fileUri srcText filePPED notes + Debug.debugM Debug.Temp "Bindings" localBindingTypes let codeActionRanges = codeActions & foldMap (\(RangedCodeAction {_codeActionRanges, _codeAction}) -> (,_codeAction) <$> _codeActionRanges) @@ -155,11 +160,11 @@ fileAnalysisWorker = forever do for freshlyCheckedFiles \(FileAnalysis {fileUri, fileVersion, diagnostics}) -> do reportDiagnostics fileUri (Just fileVersion) $ fold diagnostics -analyseFile :: (Foldable f) => Uri -> Text -> PPED.PrettyPrintEnvDecl -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction]) +analyseFile :: (Foldable f) => Uri -> Text -> PPED.PrettyPrintEnvDecl -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction], MonoidalMap Symbol (IntervalMap Position (Type.Type Symbol Ann))) analyseFile fileUri srcText pped notes = do let ppe = PPED.suffixifiedPPE pped - (noteDiags, noteActions) <- analyseNotes fileUri ppe (Text.unpack srcText) notes - pure (noteDiags, noteActions) + (noteDiags, noteActions, localBindingTypes) <- analyseNotes fileUri ppe (Text.unpack srcText) notes + pure (noteDiags, noteActions, localBindingTypes) -- | Returns diagnostics which show a warning diagnostic when editing a term that's conflicted in the -- codebase. @@ -205,7 +210,7 @@ getTokenMap tokens = ) & fold -analyseNotes :: (Foldable f) => Uri -> PrettyPrintEnv -> String -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction]) +analyseNotes :: (Foldable f) => Uri -> PrettyPrintEnv -> String -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction], MonoidalMap Symbol (IntervalMap Position (Type.Type Symbol Ann))) analyseNotes fileUri ppe src notes = do flip foldMapM notes \note -> case note of Result.TypeError errNote@(Context.ErrorNote {cause}) -> do @@ -269,10 +274,10 @@ analyseNotes fileUri ppe src notes = do nameResolutionCodeActions diags suggestions <> typeHoleActions _ -> pure [] - pure (diags, codeActions) + pure (diags, codeActions, mempty) Result.NameResolutionFailures {} -> do -- TODO: diagnostics/code actions for resolution failures - pure (noteDiagnostic note todoAnnotation, []) + pure (noteDiagnostic note todoAnnotation, [], mempty) Result.Parsing err -> do let diags = do (errMsg, ranges) <- PrintError.renderParseErrors src err @@ -280,15 +285,15 @@ analyseNotes fileUri ppe src notes = do range <- ranges pure $ mkDiagnostic fileUri (uToLspRange range) DiagnosticSeverity_Error txtMsg [] -- TODO: Some parsing errors likely have reasonable code actions - pure (diags, []) + pure (diags, [], mempty) Result.UnknownSymbol _ loc -> - pure (noteDiagnostic note (singleRange loc), []) + pure (noteDiagnostic note (singleRange loc), [], mempty) Result.TypeInfo info -> do case info of - Context.LetBinding v _loc typ _r -> Debug.debugM Debug.Temp "TypeInfo note" (v, typ) - _ -> pure () - -- No relevant diagnostics from type info. - pure ([], []) + Context.LetBinding v loc typ _r -> pure . fromMaybe mempty $ do + interval <- Cv.annToInterval loc + pure ([], [], MonMap.singleton v $ IntervalMap.singleton interval typ) + _ -> pure ([], [], mempty) Result.CompilerBug cbug -> do let ranges = case cbug of Result.TopLevelComponentNotFound _ trm -> singleRange $ ABT.annotation trm @@ -308,7 +313,7 @@ analyseNotes fileUri ppe src notes = do Context.UnknownExistentialVariable _sym _con -> todoAnnotation Context.IllegalContextExtension _con _el _s -> todoAnnotation Context.OtherBug _s -> todoAnnotation - pure (noteDiagnostic note ranges, []) + pure (noteDiagnostic note ranges, [], mempty) where -- Diagnostics with this return value haven't been properly configured yet. todoAnnotation = [] diff --git a/unison-cli/src/Unison/LSP/Hover.hs b/unison-cli/src/Unison/LSP/Hover.hs index aa6e6b7cf3..1fdca928af 100644 --- a/unison-cli/src/Unison/LSP/Hover.hs +++ b/unison-cli/src/Unison/LSP/Hover.hs @@ -5,6 +5,9 @@ module Unison.LSP.Hover where import Control.Lens hiding (List) import Control.Monad.Reader +import Data.IntervalMap.Lazy qualified as IM +import Data.IntervalMap.Lazy qualified as IntervalMap +import Data.Map.Monoidal qualified as MonMap import Data.Text qualified as Text import Language.LSP.Protocol.Lens import Language.LSP.Protocol.Message qualified as Msg @@ -12,6 +15,7 @@ import Language.LSP.Protocol.Types import Unison.ABT qualified as ABT 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.VFS qualified as VFS @@ -28,14 +32,13 @@ 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,22 @@ hoverInfo uri pos = typ <- hoistMaybe $ builtinTypeForPatternLiterals pat pure (": " <> typ) + hoverInfoForLocalVar :: MaybeT Lsp Text + hoverInfoForLocalVar = do + LSPQ.nodeAtPosition uri pos >>= \case + LSPQ.TermNode (Term.Var' v) -> do + FileAnalysis {localBindingTypes} <- FileAnalysis.getFileAnalysis uri + varContexts <- hoistMaybe $ MonMap.lookup v localBindingTypes + -- An interval contining the exact location of the cursor + let posInterval = (IM.ClosedInterval pos pos) + (_range, typ) <- hoistMaybe $ IntervalMap.lookupLT posInterval varContexts + + pped <- lift $ ppedForFile uri + pure $ renderTypeSigForHover pped (Var.name v) typ + LSPQ.TermNode {} -> empty + LSPQ.TypeNode {} -> empty + LSPQ.PatternNode _pat -> empty + 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..8c271ab914 100644 --- a/unison-cli/src/Unison/LSP/Types.hs +++ b/unison-cli/src/Unison/LSP/Types.hs @@ -15,6 +15,7 @@ import Data.Aeson qualified as Aeson import Data.IntervalMap.Lazy (IntervalMap) import Data.IntervalMap.Lazy qualified as IM import Data.Map qualified as Map +import Data.Map.Monoidal (MonoidalMap) import Ki qualified import Language.LSP.Logging qualified as LSP import Language.LSP.Protocol.Lens @@ -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 :: MonoidalMap Symbol (IntervalMap Position (Type Symbol Ann)), typeSignatureHints :: Map Symbol TypeSignatureHint, fileSummary :: Maybe FileSummary } diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 6923ab417a..2926add725 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 @@ -216,6 +216,7 @@ library , lsp-types >=2.0.2.0 , megaparsec , memory + , monoidal-containers , mtl , network , network-simple @@ -358,6 +359,7 @@ executable transcripts , lsp-types >=2.0.2.0 , megaparsec , memory + , monoidal-containers , mtl , network , network-simple @@ -508,6 +510,7 @@ test-suite cli-tests , lsp-types >=2.0.2.0 , megaparsec , memory + , monoidal-containers , mtl , network , network-simple From 00d32cc4fdd10c7934903e90fe8b633ae8e5a4f2 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 20 May 2024 11:33:52 -0700 Subject: [PATCH 03/11] Cleanup --- unison-cli/src/Unison/LSP/FileAnalysis.hs | 1 - unison-cli/src/Unison/LSP/Hover.hs | 21 +++++++++++---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index 59d5c1491c..abe6b3d748 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -109,7 +109,6 @@ checkFile doc = runMaybeT do pure (typecheckingNotes, Just parsedFile, maybeTypecheckedFile) filePPED <- lift $ ppedForFileHelper parsedFile typecheckedFile (errDiagnostics, codeActions, localBindingTypes) <- lift $ analyseFile fileUri srcText filePPED notes - Debug.debugM Debug.Temp "Bindings" localBindingTypes let codeActionRanges = codeActions & foldMap (\(RangedCodeAction {_codeActionRanges, _codeAction}) -> (,_codeAction) <$> _codeActionRanges) diff --git a/unison-cli/src/Unison/LSP/Hover.hs b/unison-cli/src/Unison/LSP/Hover.hs index 1fdca928af..4e8b80d3cd 100644 --- a/unison-cli/src/Unison/LSP/Hover.hs +++ b/unison-cli/src/Unison/LSP/Hover.hs @@ -125,20 +125,21 @@ hoverInfo uri pos = hoverInfoForLocalVar :: MaybeT Lsp Text hoverInfoForLocalVar = do - LSPQ.nodeAtPosition uri pos >>= \case - LSPQ.TermNode (Term.Var' v) -> do - FileAnalysis {localBindingTypes} <- FileAnalysis.getFileAnalysis uri - varContexts <- hoistMaybe $ MonMap.lookup v localBindingTypes - -- An interval contining the exact location of the cursor - let posInterval = (IM.ClosedInterval pos pos) - (_range, typ) <- hoistMaybe $ IntervalMap.lookupLT posInterval varContexts - - pped <- lift $ ppedForFile uri - pure $ renderTypeSigForHover pped (Var.name v) typ + node <- LSPQ.nodeAtPosition uri pos + localVar <- case node of + LSPQ.TermNode (Term.Var' v) -> pure $ v LSPQ.TermNode {} -> empty LSPQ.TypeNode {} -> empty LSPQ.PatternNode _pat -> empty + FileAnalysis {localBindingTypes} <- FileAnalysis.getFileAnalysis uri + varContexts <- hoistMaybe $ MonMap.lookup localVar localBindingTypes + -- An interval contining the exact location of the cursor + let posInterval = (IM.ClosedInterval pos pos) + (_range, typ) <- hoistMaybe $ IntervalMap.lookupLT posInterval varContexts + pped <- lift $ ppedForFile uri + pure $ renderTypeSigForHover pped (Var.name localVar) typ + hoistMaybe :: Maybe a -> MaybeT Lsp a hoistMaybe = MaybeT . pure From ac9a02b3b6e11e8e1e7c84664eb0d2784e5a027a Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 13 Jun 2024 17:16:31 -0700 Subject: [PATCH 04/11] Improve local binding inference --- unison-cli/src/Unison/LSP/FileAnalysis.hs | 242 ++++++++++++---------- 1 file changed, 128 insertions(+), 114 deletions(-) diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index abe6b3d748..5351c32c7b 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -7,12 +7,11 @@ 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.IntervalMap.Lazy qualified as IntervalMap import Data.Map qualified as Map -import Data.Map.Monoidal (MonoidalMap) -import Data.Map.Monoidal qualified as MonMap +import Data.Map.Monoidal qualified as MonoidalMap import Data.Set qualified as Set import Data.Text qualified as Text import Data.These @@ -64,7 +63,6 @@ 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.Type qualified as Type import Unison.Typechecker.Context qualified as Context import Unison.Typechecker.TypeError qualified as TypeError import Unison.UnisonFile qualified as UF @@ -97,18 +95,36 @@ 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) + -- This is silly, but after applying TDNR we can just re-typecheck the already substituted file to get the correct types of + -- local bindings from after TDNR. + localBindings <- + maybeTypecheckedFile & foldMapM \tf -> do + let parsedFile = UF.discardTypes tf + typecheckingEnv' <- computeTypecheckingEnvironment ShouldUseTndr'No cb ambientAbilities parsedFile + let Result.Result afterTDNRTypecheckingNotes' _maybeTypecheckedFile' = FileParsers.synthesizeFile typecheckingEnv' parsedFile + Debug.debugM Debug.Temp "After typechecking notes" afterTDNRTypecheckingNotes' + afterTDNRTypecheckingNotes' + & mapMaybe \case + Result.TypeInfo (Context.LetBinding v loc typ _) -> + Cv.annToInterval loc <&> \interval -> (v, (IM.singleton interval typ)) + _ -> Nothing + & Foldable.toList + & Debug.debug Debug.Temp "Local Bindings 1" + & MonoidalMap.fromList + & pure + pure (localBindings, typecheckingNotes, Just parsedFile, maybeTypecheckedFile) + Debug.debugM Debug.Temp "Local Bindings 2" localBindingTypes filePPED <- lift $ ppedForFileHelper parsedFile typecheckedFile - (errDiagnostics, codeActions, localBindingTypes) <- lift $ analyseFile fileUri srcText filePPED notes + (errDiagnostics, codeActions) <- lift $ analyseFile fileUri srcText filePPED notes let codeActionRanges = codeActions & foldMap (\(RangedCodeAction {_codeActionRanges, _codeAction}) -> (,_codeAction) <$> _codeActionRanges) @@ -159,11 +175,11 @@ fileAnalysisWorker = forever do for freshlyCheckedFiles \(FileAnalysis {fileUri, fileVersion, diagnostics}) -> do reportDiagnostics fileUri (Just fileVersion) $ fold diagnostics -analyseFile :: (Foldable f) => Uri -> Text -> PPED.PrettyPrintEnvDecl -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction], MonoidalMap Symbol (IntervalMap Position (Type.Type Symbol Ann))) +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, localBindingTypes) <- analyseNotes fileUri ppe (Text.unpack srcText) notes - pure (noteDiags, noteActions, localBindingTypes) + (noteDiags, noteActions) <- analyseNotes 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 -- codebase. @@ -209,111 +225,109 @@ getTokenMap tokens = ) & fold -analyseNotes :: (Foldable f) => Uri -> PrettyPrintEnv -> String -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction], MonoidalMap Symbol (IntervalMap Position (Type.Type Symbol Ann))) +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, mempty) - Result.NameResolutionFailures {} -> do - -- TODO: diagnostics/code actions for resolution failures - pure (noteDiagnostic note todoAnnotation, [], mempty) - 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, [], mempty) - Result.UnknownSymbol _ loc -> - pure (noteDiagnostic note (singleRange loc), [], mempty) - Result.TypeInfo info -> do - case info of - Context.LetBinding v loc typ _r -> pure . fromMaybe mempty $ do - interval <- Cv.annToInterval loc - pure ([], [], MonMap.singleton v $ IntervalMap.singleton interval typ) - _ -> pure ([], [], mempty) - 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, [], mempty) + 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])] From 5d9e36cb31bfa85b27b871bf87441e6d32b37f2d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 13 Jun 2024 18:44:35 -0700 Subject: [PATCH 05/11] Add annotations for lambda bindings --- .../src/Unison/Typechecker/Context.hs | 42 ++++++++++++------- 1 file changed, 26 insertions(+), 16 deletions(-) diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 282dd790bf..03863fd7cd 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -362,7 +362,7 @@ data InfoNote v 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. - LetBinding v loc (Type.Type v loc) RedundantTypeAnnotation + LetBinding v loc (Type.Type v loc) deriving (Show) topLevelComponent :: (Var v) => [(v, Type.Type v loc, RedundantTypeAnnotation)] -> InfoNote v loc @@ -1083,36 +1083,39 @@ generalizeExistentials' t = isExistential _ = False noteBindingType :: - forall v loc f a. + forall v loc. (Ord loc, Var v) => Term.IsTop -> loc -> - ABT.Subst f v a -> + v -> Term v loc -> Type v loc -> M v loc () -noteBindingType top span e binding typ = case binding of +noteBindingType top span v binding typ = case binding of Term.Ann' strippedBinding _ -> do inferred <- (Just <$> synthesizeTop strippedBinding) `orElse` pure Nothing case inferred of Nothing -> do - let v = Var.reset (ABT.variable e) + let v = Var.reset v let t = generalizeAndUnTypeVar typ let redundant = False note [(v, t, redundant)] Just inferred -> do redundant <- isRedundant typ inferred - note [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, redundant)] + note [(Var.reset v, generalizeAndUnTypeVar typ, redundant)] -- The signature didn't exist, so was definitely redundant _ -> note - [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, True)] + [(Var.reset v, generalizeAndUnTypeVar typ, True)] where note :: (Var v) => [(v, Type.Type v loc, RedundantTypeAnnotation)] -> M v loc () note infos = if top then btw $ topLevelComponent infos - else for_ infos \(v, t, r) -> btw $ LetBinding v span t r + else for_ infos \(v, t, _r) -> noteLocalBinding v span t + +noteLocalBinding :: (Var v) => v -> loc -> Type.Type v loc -> M v loc () +noteLocalBinding v span t = btw $ LetBinding v span t synthesizeTop :: (Var v) => @@ -1230,14 +1233,14 @@ synthesizeWanted abt@(Term.Let1Top' top binding e) = do appendContext [Ann v' tbinding] (t, w) <- synthesize (ABT.bindInheritAnnotation e (Term.var () v')) t <- applyM t - noteBindingType top (ABT.annotation abt) e binding tbinding + noteBindingType top (ABT.annotation abt) (ABT.variable e) binding 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) @@ -1340,6 +1343,8 @@ 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 + noteLocalBinding i l (TypeVar.lowerType $ solvedInputType) pure (t, []) | Term.If' cond t f <- e = do cwant <- scope InIfCond $ check cond (Type.boolean l) @@ -1838,10 +1843,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 @@ -1865,8 +1871,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) -> noteLocalBinding v span (TypeVar.lowerType t) + pure body where annotateLetRecBindings' useUserAnnotations = do (bindings, body) <- letrec freshenVar @@ -2461,9 +2469,11 @@ checkWanted want (Term.Let1Top' top binding m) t = do 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 + -- TODO: I don't think we want to emit types for local bindings from here, but will need + -- to refactor to do that properly + e <- annotateLetRecBindings (ABT.annotation abt) isTop lr checkWanted want e t checkWanted want e@(Term.Match' scrut cases) t = do (scrutType, swant) <- synthesize scrut From 5fdf1f7d5b4605867203c9f7483e7ed6d425b035 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 13 Jun 2024 18:44:35 -0700 Subject: [PATCH 06/11] Fix hover info for local bindings --- unison-cli/src/Unison/LSP/FileAnalysis.hs | 31 ++++++++++++----------- unison-cli/src/Unison/LSP/Hover.hs | 12 ++++++--- unison-cli/src/Unison/LSP/Types.hs | 2 +- 3 files changed, 26 insertions(+), 19 deletions(-) diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index 5351c32c7b..b8c6f504a6 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -57,6 +57,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 @@ -107,22 +108,22 @@ checkFile doc = runMaybeT do -- This is silly, but after applying TDNR we can just re-typecheck the already substituted file to get the correct types of -- local bindings from after TDNR. localBindings <- - maybeTypecheckedFile & foldMapM \tf -> do - let parsedFile = UF.discardTypes tf - typecheckingEnv' <- computeTypecheckingEnvironment ShouldUseTndr'No cb ambientAbilities parsedFile - let Result.Result afterTDNRTypecheckingNotes' _maybeTypecheckedFile' = FileParsers.synthesizeFile typecheckingEnv' parsedFile - Debug.debugM Debug.Temp "After typechecking notes" afterTDNRTypecheckingNotes' - afterTDNRTypecheckingNotes' - & mapMaybe \case - Result.TypeInfo (Context.LetBinding v loc typ _) -> - Cv.annToInterval loc <&> \interval -> (v, (IM.singleton interval typ)) - _ -> Nothing - & Foldable.toList - & Debug.debug Debug.Temp "Local Bindings 1" - & MonoidalMap.fromList - & pure + -- maybeTypecheckedFile & foldMapM \tf -> do + -- let parsedFile = UF.discardTypes tf + -- typecheckingEnv' <- computeTypecheckingEnvironment ShouldUseTndr'No cb ambientAbilities parsedFile + -- let Result.Result afterTDNRTypecheckingNotes' _maybeTypecheckedFile' = FileParsers.synthesizeFile typecheckingEnv' parsedFile + -- Debug.debugM Debug.Temp "After typechecking notes" afterTDNRTypecheckingNotes' + -- afterTDNRTypecheckingNotes' + typecheckingNotes + & mapMaybe \case + Result.TypeInfo (Context.LetBinding (Symbol.Symbol _ (Var.User v)) loc typ) -> + Cv.annToInterval loc <&> \interval -> (v, (IM.singleton interval typ)) + _ -> Nothing + & Foldable.toList + & MonoidalMap.fromList + & pure pure (localBindings, typecheckingNotes, Just parsedFile, maybeTypecheckedFile) - Debug.debugM Debug.Temp "Local Bindings 2" localBindingTypes + Debug.debugM Debug.Temp "Local Bindings" localBindingTypes filePPED <- lift $ ppedForFileHelper parsedFile typecheckedFile (errDiagnostics, codeActions) <- lift $ analyseFile fileUri srcText filePPED notes let codeActionRanges = diff --git a/unison-cli/src/Unison/LSP/Hover.hs b/unison-cli/src/Unison/LSP/Hover.hs index 4e8b80d3cd..8f842a3080 100644 --- a/unison-cli/src/Unison/LSP/Hover.hs +++ b/unison-cli/src/Unison/LSP/Hover.hs @@ -13,6 +13,7 @@ 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 @@ -28,6 +29,7 @@ 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 @@ -126,19 +128,23 @@ hoverInfo uri pos = hoverInfoForLocalVar :: MaybeT Lsp Text hoverInfoForLocalVar = do node <- LSPQ.nodeAtPosition uri pos + Debug.debugM Debug.Temp "node" node localVar <- case node of - LSPQ.TermNode (Term.Var' v) -> pure $ v + LSPQ.TermNode (Term.Var' (Symbol.Symbol _ (Var.User v))) -> pure $ v LSPQ.TermNode {} -> empty LSPQ.TypeNode {} -> empty LSPQ.PatternNode _pat -> empty - + Debug.debugM Debug.Temp "localVar" localVar FileAnalysis {localBindingTypes} <- FileAnalysis.getFileAnalysis uri varContexts <- hoistMaybe $ MonMap.lookup localVar localBindingTypes + + Debug.debugM Debug.Temp "varContexts" varContexts -- An interval contining the exact location of the cursor let posInterval = (IM.ClosedInterval pos pos) + Debug.debugM Debug.Temp "posInterval" posInterval (_range, typ) <- hoistMaybe $ IntervalMap.lookupLT posInterval varContexts pped <- lift $ ppedForFile uri - pure $ renderTypeSigForHover pped (Var.name localVar) typ + 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 8c271ab914..043d9d7c09 100644 --- a/unison-cli/src/Unison/LSP/Types.hs +++ b/unison-cli/src/Unison/LSP/Types.hs @@ -129,7 +129,7 @@ data FileAnalysis = FileAnalysis -- 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 :: MonoidalMap Symbol (IntervalMap Position (Type Symbol Ann)), + localBindingTypes :: MonoidalMap Text (IntervalMap Position (Type Symbol Ann)), typeSignatureHints :: Map Symbol TypeSignatureHint, fileSummary :: Maybe FileSummary } From 21e4959a7cb6dfb367c28276e14fe19a886398ba Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 14 Jun 2024 09:19:45 -0700 Subject: [PATCH 07/11] Don't typecheck twice, correctly find best match for each var. --- .../src/Unison/Typechecker/Context.hs | 24 ++-- unison-cli/src/Unison/LSP/FileAnalysis.hs | 13 +- unison-cli/src/Unison/LSP/Hover.hs | 31 +++-- unison-cli/src/Unison/LSP/Types.hs | 4 +- .../src/Unison/LSP/Util/IntersectionMap.hs | 111 ++++++++++++++++++ unison-cli/unison-cli.cabal | 1 + 6 files changed, 149 insertions(+), 35 deletions(-) create mode 100644 unison-cli/src/Unison/LSP/Util/IntersectionMap.hs diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 03863fd7cd..45cee71b02 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -358,11 +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 local binding, and the scope of that binding as a loc. + | -- 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. - LetBinding v loc (Type.Type v loc) + -- 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 @@ -1109,13 +1110,16 @@ noteBindingType top span v binding typ = case binding of [(Var.reset v, generalizeAndUnTypeVar typ, True)] where note :: (Var v) => [(v, Type.Type v loc, RedundantTypeAnnotation)] -> M v loc () - note infos = - if top - then btw $ topLevelComponent infos - else for_ infos \(v, t, _r) -> noteLocalBinding v span t + note infos = do + -- Also note top-level components as standard let bindings for the LSP + for_ infos \(v, t, _r) -> noteBinding v span t + when top (btw $ topLevelComponent infos) -noteLocalBinding :: (Var v) => v -> loc -> Type.Type v loc -> M v loc () -noteLocalBinding v span t = btw $ LetBinding v span t +-- | 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. +noteBinding :: (Var v) => v -> loc -> Type.Type v loc -> M v loc () +noteBinding v span t = btw $ VarBinding v span t synthesizeTop :: (Var v) => @@ -1344,7 +1348,7 @@ synthesizeWanted e 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 - noteLocalBinding i l (TypeVar.lowerType $ solvedInputType) + noteBinding i l (TypeVar.lowerType $ solvedInputType) pure (t, []) | Term.If' cond t f <- e = do cwant <- scope InIfCond $ check cond (Type.boolean l) @@ -1873,7 +1877,7 @@ annotateLetRecBindings span isTop letrec = pure body 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) -> noteLocalBinding v span (TypeVar.lowerType t) + for_ vts \(v, t) -> noteBinding v span (TypeVar.lowerType t) pure body where annotateLetRecBindings' useUserAnnotations = do diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index b8c6f504a6..1537ddded1 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -11,7 +11,6 @@ import Data.Foldable qualified as Foldable import Data.IntervalMap.Lazy (IntervalMap) import Data.IntervalMap.Lazy qualified as IM import Data.Map qualified as Map -import Data.Map.Monoidal qualified as MonoidalMap import Data.Set qualified as Set import Data.Text qualified as Text import Data.These @@ -25,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 @@ -39,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) @@ -115,12 +116,12 @@ checkFile doc = runMaybeT do -- Debug.debugM Debug.Temp "After typechecking notes" afterTDNRTypecheckingNotes' -- afterTDNRTypecheckingNotes' typecheckingNotes - & mapMaybe \case - Result.TypeInfo (Context.LetBinding (Symbol.Symbol _ (Var.User v)) loc typ) -> - Cv.annToInterval loc <&> \interval -> (v, (IM.singleton interval typ)) - _ -> Nothing & Foldable.toList - & MonoidalMap.fromList + & 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 "Local Bindings" localBindingTypes diff --git a/unison-cli/src/Unison/LSP/Hover.hs b/unison-cli/src/Unison/LSP/Hover.hs index 8f842a3080..92c30cf159 100644 --- a/unison-cli/src/Unison/LSP/Hover.hs +++ b/unison-cli/src/Unison/LSP/Hover.hs @@ -5,9 +5,6 @@ module Unison.LSP.Hover where import Control.Lens hiding (List) import Control.Monad.Reader -import Data.IntervalMap.Lazy qualified as IM -import Data.IntervalMap.Lazy qualified as IntervalMap -import Data.Map.Monoidal qualified as MonMap import Data.Text qualified as Text import Language.LSP.Protocol.Lens import Language.LSP.Protocol.Message qualified as Msg @@ -19,6 +16,7 @@ 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) @@ -127,22 +125,21 @@ hoverInfo uri pos = hoverInfoForLocalVar :: MaybeT Lsp Text hoverInfoForLocalVar = do - node <- LSPQ.nodeAtPosition uri pos - Debug.debugM Debug.Temp "node" node - localVar <- 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 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 - varContexts <- hoistMaybe $ MonMap.lookup localVar localBindingTypes - - Debug.debugM Debug.Temp "varContexts" varContexts - -- An interval contining the exact location of the cursor - let posInterval = (IM.ClosedInterval pos pos) - Debug.debugM Debug.Temp "posInterval" posInterval - (_range, typ) <- hoistMaybe $ IntervalMap.lookupLT posInterval varContexts + 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 diff --git a/unison-cli/src/Unison/LSP/Types.hs b/unison-cli/src/Unison/LSP/Types.hs index 043d9d7c09..5458df3c27 100644 --- a/unison-cli/src/Unison/LSP/Types.hs +++ b/unison-cli/src/Unison/LSP/Types.hs @@ -15,7 +15,6 @@ import Data.Aeson qualified as Aeson import Data.IntervalMap.Lazy (IntervalMap) import Data.IntervalMap.Lazy qualified as IM import Data.Map qualified as Map -import Data.Map.Monoidal (MonoidalMap) import Ki qualified import Language.LSP.Logging qualified as LSP import Language.LSP.Protocol.Lens @@ -29,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) @@ -129,7 +129,7 @@ data FileAnalysis = FileAnalysis -- 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 :: MonoidalMap Text (IntervalMap Position (Type Symbol Ann)), + 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 2926add725..2f12615529 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -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 From 50382b8d75a2a458a2dc1c25cbc0519359827f83 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 14 Jun 2024 10:38:50 -0700 Subject: [PATCH 08/11] Get letrec bindings working in functions --- parser-typechecker/src/Unison/Typechecker/Context.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 45cee71b02..8f207354b5 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -105,6 +105,7 @@ 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 qualified Unison.Debug as Debug type TypeVar v loc = TypeVar.TypeVar (B.Blank loc) v @@ -1922,6 +1923,8 @@ annotateLetRecBindings span isTop letrec = gen bindingType _arity = generalizeExistentials ctx2 bindingType bindingTypesGeneralized = zipWith gen bindingTypes bindingArities annotations = zipWith Ann vs bindingTypesGeneralized + -- for_ (zip3 vs bindings bindingTypesGeneralized) \(v, b, t) -> do + -- noteBinding v (loc b) (TypeVar.lowerType t) appendContext annotations pure (body, vs `zip` bindingTypesGeneralized) @@ -2460,7 +2463,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 @@ -2469,14 +2472,15 @@ 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) + -- Need to somehow fix the annotation on these + Debug.debugM Debug.Temp "checkWanted" $ (v, binding) + noteBinding 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 abt@(Term.LetRecTop' isTop lr) t = markThenRetractWanted (Var.named "let-rec-marker") $ do - -- TODO: I don't think we want to emit types for local bindings from here, but will need - -- to refactor to do that properly e <- annotateLetRecBindings (ABT.annotation abt) isTop lr checkWanted want e t checkWanted want e@(Term.Match' scrut cases) t = do From 24c3751129913694c148234e6f9b8f55b611131a Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 14 Jun 2024 11:32:43 -0700 Subject: [PATCH 09/11] disable binding types --- .gitignore | 3 ++ .../src/Unison/Typechecker/Context.hs | 35 ++++++++++--------- unison-cli/src/Unison/LSP/FileAnalysis.hs | 9 +++-- unison-cli/src/Unison/Main.hs | 5 ++- 4 files changed, 29 insertions(+), 23 deletions(-) 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 8f207354b5..a4ce58615f 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -105,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 qualified Unison.Debug as Debug type TypeVar v loc = TypeVar.TypeVar (B.Blank loc) v @@ -1093,7 +1092,7 @@ noteBindingType :: Term v loc -> Type v loc -> M v loc () -noteBindingType top span v binding typ = case binding of +noteBindingType top _span v binding typ = case binding of Term.Ann' strippedBinding _ -> do inferred <- (Just <$> synthesizeTop strippedBinding) `orElse` pure Nothing case inferred of @@ -1111,16 +1110,16 @@ noteBindingType top span v binding typ = case binding of [(Var.reset v, generalizeAndUnTypeVar typ, True)] where note :: (Var v) => [(v, Type.Type v loc, RedundantTypeAnnotation)] -> M v loc () - note infos = do + note comps = do -- Also note top-level components as standard let bindings for the LSP - for_ infos \(v, t, _r) -> noteBinding v span t - when top (btw $ topLevelComponent infos) + -- for_ comps \(v, t, _r) -> noteVarBinding v span t + when top (btw $ topLevelComponent comps) -- | 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. -noteBinding :: (Var v) => v -> loc -> Type.Type v loc -> M v loc () -noteBinding v span t = btw $ VarBinding v span t +_noteVarBinding :: (Var v) => v -> loc -> Type.Type v loc -> M v loc () +_noteVarBinding _v _span _t = pure () -- btw $ VarBinding v span t synthesizeTop :: (Var v) => @@ -1348,8 +1347,10 @@ 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 - noteBinding i l (TypeVar.lowerType $ solvedInputType) + + -- TODO revive + -- 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) @@ -1852,7 +1853,7 @@ annotateLetRecBindings :: Term.IsTop -> ((v -> M v loc v) -> M v loc ([(v, Term v loc)], Term v loc)) -> M v loc (Term v loc) -annotateLetRecBindings span 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 @@ -1877,8 +1878,9 @@ annotateLetRecBindings span isTop letrec = topLevelComponent ((\(v, b) -> (Var.reset v, b, False)) . unTypeVar <$> vts) pure body 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) -> noteBinding v span (TypeVar.lowerType t) + (body, _vts) <- annotateLetRecBindings' True + -- TODO revive + -- for_ vts \(v, t) -> noteVarBinding v span (TypeVar.lowerType t) pure body where annotateLetRecBindings' useUserAnnotations = do @@ -1924,7 +1926,7 @@ annotateLetRecBindings span isTop letrec = bindingTypesGeneralized = zipWith gen bindingTypes bindingArities annotations = zipWith Ann vs bindingTypesGeneralized -- for_ (zip3 vs bindings bindingTypesGeneralized) \(v, b, t) -> do - -- noteBinding v (loc b) (TypeVar.lowerType t) + -- noteVarBinding v (loc b) (TypeVar.lowerType t) appendContext annotations pure (body, vs `zip` bindingTypesGeneralized) @@ -2463,7 +2465,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 abt@(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 @@ -2472,9 +2474,8 @@ checkWanted want abt@(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) - -- Need to somehow fix the annotation on these - Debug.debugM Debug.Temp "checkWanted" $ (v, binding) - noteBinding v (ABT.annotation abt) (TypeVar.lowerType tbinding) + -- TODO revive + -- 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 diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index 1537ddded1..7413c8403e 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -108,7 +108,7 @@ checkFile doc = runMaybeT do let Result.Result typecheckingNotes maybeTypecheckedFile = FileParsers.synthesizeFile typecheckingEnv parsedFile -- This is silly, but after applying TDNR we can just re-typecheck the already substituted file to get the correct types of -- local bindings from after TDNR. - localBindings <- + _localBindings <- -- maybeTypecheckedFile & foldMapM \tf -> do -- let parsedFile = UF.discardTypes tf -- typecheckingEnv' <- computeTypecheckingEnvironment ShouldUseTndr'No cb ambientAbilities parsedFile @@ -123,8 +123,11 @@ checkFile doc = runMaybeT do 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 "Local Bindings" localBindingTypes + pure (mempty, 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 = diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index 32e829c0b1..32a08a5ffd 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -79,7 +79,6 @@ import Unison.CommandLine.Main qualified as CommandLine import Unison.CommandLine.Types qualified as CommandLine import Unison.CommandLine.Welcome (CodebaseInitStatus (..)) import Unison.CommandLine.Welcome qualified as Welcome -import Unison.LSP qualified as LSP import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal qualified as PT @@ -137,7 +136,7 @@ main version = do -- hSetBuffering stdout NoBuffering -- cool (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName (Text.unpack (Version.gitDescribeWithDate version)) nrtp <- fixNativeRuntimePath (nativeRuntimePath globalOptions) - let GlobalOptions {codebasePathOption = mCodePathOption, exitOption, lspFormattingConfig} = globalOptions + let GlobalOptions {codebasePathOption = mCodePathOption, exitOption} = globalOptions withConfig mCodePathOption \config -> do currentDir <- getCurrentDirectory case command of @@ -312,7 +311,7 @@ main version = do -- prevent UCM from shutting down properly. Hopefully we can re-enable LSP on -- Windows when we move to GHC 9.* -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1224 - void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar rootCausalHashVar) (readTVar pathVar) + -- void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar rootCausalHashVar) (readTVar pathVar) Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do case exitOption of DoNotExit -> do From fb06b745ace32d8928aa7bdf83c3070b51e49827 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 14 Jun 2024 12:39:14 -0700 Subject: [PATCH 10/11] Revive top-level var bindings --- .../src/Unison/Typechecker/Context.hs | 89 ++++++++----------- unison-cli/src/Unison/LSP/FileAnalysis.hs | 14 +-- unison-cli/src/Unison/Main.hs | 5 +- 3 files changed, 44 insertions(+), 64 deletions(-) diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index a4ce58615f..f6e8d42923 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -480,7 +480,6 @@ scope :: PathElement v loc -> M v loc a -> M v loc a scope p (MT m) = MT \ppe pmcSwitch datas effects env -> mapErrors (scope' p) (m ppe pmcSwitch datas effects env) newtype Context v loc = Context [(Element v loc, Info v loc)] - deriving stock (Show) data Info v loc = Info { existentialVars :: Set v, -- set of existentials seen so far @@ -489,7 +488,6 @@ data Info v loc = Info termVarAnnotations :: Map v (Type v loc), allVars :: Set v -- all variables seen so far } - deriving stock (Show) -- | The empty context context0 :: Context v loc @@ -1083,43 +1081,35 @@ generalizeExistentials' t = isExistential TypeVar.Existential {} = True isExistential _ = False -noteBindingType :: - forall v loc. +noteTopLevelType :: (Ord loc, Var v) => - Term.IsTop -> - loc -> - v -> + ABT.Subst f v a -> Term v loc -> Type v loc -> M v loc () -noteBindingType top _span v binding typ = case binding of +noteTopLevelType e binding typ = case binding of Term.Ann' strippedBinding _ -> do inferred <- (Just <$> synthesizeTop strippedBinding) `orElse` pure Nothing case inferred of Nothing -> do - let v = Var.reset v - let t = generalizeAndUnTypeVar typ - let redundant = False - note [(v, t, redundant)] + btw $ + topLevelComponent + [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, False)] Just inferred -> do redundant <- isRedundant typ inferred - note [(Var.reset v, generalizeAndUnTypeVar typ, redundant)] + btw $ + topLevelComponent + [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, redundant)] -- The signature didn't exist, so was definitely redundant - _ -> - note - [(Var.reset v, generalizeAndUnTypeVar typ, True)] - where - note :: (Var v) => [(v, Type.Type v loc, RedundantTypeAnnotation)] -> M v loc () - note comps = do - -- Also note top-level components as standard let bindings for the LSP - -- for_ comps \(v, t, _r) -> noteVarBinding v span t - when top (btw $ topLevelComponent comps) - + _ -> 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 = pure () -- btw $ VarBinding v span t +noteVarBinding :: (Var v) => v -> loc -> Type.Type v loc -> M v loc () +noteVarBinding v span t = btw $ VarBinding v span t synthesizeTop :: (Var v) => @@ -1237,7 +1227,8 @@ synthesizeWanted abt@(Term.Let1Top' top binding e) = do appendContext [Ann v' tbinding] (t, w) <- synthesize (ABT.bindInheritAnnotation e (Term.var () v')) t <- applyM t - noteBindingType top (ABT.annotation abt) (ABT.variable 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) @@ -1334,7 +1325,6 @@ synthesizeWanted e let it = existential' l B.Blank i ot = existential' l B.Blank o et = existential' l B.Blank e - appendContext $ [existential i, existential e, existential o, Ann arg it] when (Var.typeOf i == Var.Delay) $ do @@ -1348,9 +1338,8 @@ synthesizeWanted e ctx <- getContext let t = apply ctx $ Type.arrow l it (Type.effect l [et] ot) - -- TODO revive - -- let solvedInputType = fromMaybe it . fmap Type.getPolytype $ Map.lookup i . solvedExistentials . info $ ctx - -- noteVarBinding i l (TypeVar.lowerType $ solvedInputType) + 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) @@ -1853,7 +1842,7 @@ annotateLetRecBindings :: Term.IsTop -> ((v -> M v loc v) -> M v loc ([(v, Term v loc)], Term v loc)) -> M v loc (Term v loc) -annotateLetRecBindings _span 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 @@ -1878,9 +1867,8 @@ annotateLetRecBindings _span isTop letrec = topLevelComponent ((\(v, b) -> (Var.reset v, b, False)) . unTypeVar <$> vts) pure body else do -- If this isn't a top-level letrec, then we don't have to do anything special - (body, _vts) <- annotateLetRecBindings' True - -- TODO revive - -- for_ vts \(v, t) -> noteVarBinding v span (TypeVar.lowerType t) + (body, vts) <- annotateLetRecBindings' True + for_ vts \(v, t) -> noteVarBinding v span (TypeVar.lowerType t) pure body where annotateLetRecBindings' useUserAnnotations = do @@ -1906,8 +1894,7 @@ annotateLetRecBindings _span isTop letrec = -- Anything else, just make up a fresh existential -- which will be refined during typechecking of the binding vt <- extendExistential v - let typ = existential' (loc binding) B.Blank vt - pure $ (e, typ) + pure $ (e, existential' (loc binding) B.Blank vt) (bindings, bindingTypes) <- unzip <$> traverse f bindings appendContext (zipWith Ann vs bindingTypes) -- check each `bi` against its type @@ -1925,8 +1912,9 @@ annotateLetRecBindings _span isTop letrec = gen bindingType _arity = generalizeExistentials ctx2 bindingType bindingTypesGeneralized = zipWith gen bindingTypes bindingArities annotations = zipWith Ann vs bindingTypesGeneralized - -- for_ (zip3 vs bindings bindingTypesGeneralized) \(v, b, t) -> do - -- noteVarBinding v (loc b) (TypeVar.lowerType t) + -- 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) @@ -2230,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) @@ -2465,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 _abt@(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 @@ -2474,8 +2462,7 @@ checkWanted want _abt@(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) - -- TODO revive - -- noteVarBinding v (ABT.annotation abt) (TypeVar.lowerType 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 @@ -3414,15 +3401,15 @@ instance (Var v) => Show (Element v loc) where ++ TP.prettyStr Nothing PPE.empty t show (Marker v) = "|" ++ Text.unpack (Var.name v) ++ "|" --- instance (Ord loc, Var v) => Show (Context v loc) where --- show ctx@(Context es) = "Γ\n " ++ (intercalate "\n " . map (showElem ctx . fst)) (reverse es) --- where --- showElem _ctx (Var v) = case v of --- TypeVar.Universal x -> "@" <> show x --- e -> show e --- showElem ctx (Solved _ v (Type.Monotype t)) = "'" ++ Text.unpack (Var.name v) ++ " = " ++ TP.prettyStr Nothing PPE.empty (apply ctx t) --- showElem ctx (Ann v t) = Text.unpack (Var.name v) ++ " : " ++ TP.prettyStr Nothing PPE.empty (apply ctx t) --- showElem _ (Marker v) = "|" ++ Text.unpack (Var.name v) ++ "|" +instance (Ord loc, Var v) => Show (Context v loc) where + show ctx@(Context es) = "Γ\n " ++ (intercalate "\n " . map (showElem ctx . fst)) (reverse es) + where + showElem _ctx (Var v) = case v of + TypeVar.Universal x -> "@" <> show x + e -> show e + showElem ctx (Solved _ v (Type.Monotype t)) = "'" ++ Text.unpack (Var.name v) ++ " = " ++ TP.prettyStr Nothing PPE.empty (apply ctx t) + showElem ctx (Ann v t) = Text.unpack (Var.name v) ++ " : " ++ TP.prettyStr Nothing PPE.empty (apply ctx t) + showElem _ (Marker v) = "|" ++ Text.unpack (Var.name v) ++ "|" instance (Monad f) => Monad (MT v loc f) where return = pure diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index 7413c8403e..2c64fcd096 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -106,15 +106,7 @@ checkFile doc = runMaybeT do Result.Result _ (Just parsedFile) -> do typecheckingEnv <- computeTypecheckingEnvironment (ShouldUseTndr'Yes parsingEnv) cb ambientAbilities parsedFile let Result.Result typecheckingNotes maybeTypecheckedFile = FileParsers.synthesizeFile typecheckingEnv parsedFile - -- This is silly, but after applying TDNR we can just re-typecheck the already substituted file to get the correct types of - -- local bindings from after TDNR. - _localBindings <- - -- maybeTypecheckedFile & foldMapM \tf -> do - -- let parsedFile = UF.discardTypes tf - -- typecheckingEnv' <- computeTypecheckingEnvironment ShouldUseTndr'No cb ambientAbilities parsedFile - -- let Result.Result afterTDNRTypecheckingNotes' _maybeTypecheckedFile' = FileParsers.synthesizeFile typecheckingEnv' parsedFile - -- Debug.debugM Debug.Temp "After typechecking notes" afterTDNRTypecheckingNotes' - -- afterTDNRTypecheckingNotes' + localBindings <- typecheckingNotes & Foldable.toList & reverse -- Type notes that come later in typechecking have more information filled in. @@ -123,10 +115,10 @@ checkFile doc = runMaybeT do Cv.annToRange loc & foldMap (\(LSP.Range start end) -> (keyedSingleton v (start, end) typ)) _ -> mempty & pure - pure (mempty, typecheckingNotes, Just parsedFile, maybeTypecheckedFile) + 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 "My Local Bindings" localBindingTypes Debug.debugM Debug.Temp "AFTER Local Bindings" () filePPED <- lift $ ppedForFileHelper parsedFile typecheckedFile (errDiagnostics, codeActions) <- lift $ analyseFile fileUri srcText filePPED notes diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index 32a08a5ffd..32e829c0b1 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -79,6 +79,7 @@ import Unison.CommandLine.Main qualified as CommandLine import Unison.CommandLine.Types qualified as CommandLine import Unison.CommandLine.Welcome (CodebaseInitStatus (..)) import Unison.CommandLine.Welcome qualified as Welcome +import Unison.LSP qualified as LSP import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal qualified as PT @@ -136,7 +137,7 @@ main version = do -- hSetBuffering stdout NoBuffering -- cool (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName (Text.unpack (Version.gitDescribeWithDate version)) nrtp <- fixNativeRuntimePath (nativeRuntimePath globalOptions) - let GlobalOptions {codebasePathOption = mCodePathOption, exitOption} = globalOptions + let GlobalOptions {codebasePathOption = mCodePathOption, exitOption, lspFormattingConfig} = globalOptions withConfig mCodePathOption \config -> do currentDir <- getCurrentDirectory case command of @@ -311,7 +312,7 @@ main version = do -- prevent UCM from shutting down properly. Hopefully we can re-enable LSP on -- Windows when we move to GHC 9.* -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1224 - -- void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar rootCausalHashVar) (readTVar pathVar) + void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar rootCausalHashVar) (readTVar pathVar) Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do case exitOption of DoNotExit -> do From ab1463b28fdee02738ea370d9d93a5da6e62e9b2 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 14 Jun 2024 13:13:50 -0700 Subject: [PATCH 11/11] Remove unused libs --- unison-cli/package.yaml | 1 - unison-cli/unison-cli.cabal | 3 --- 2 files changed, 4 deletions(-) diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 1862da26a6..3402e98c92 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -48,7 +48,6 @@ dependencies: - lsp-types >= 2.0.2.0 - megaparsec - memory - - monoidal-containers - mtl - network - network-simple diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 2f12615529..8ea0bf9f02 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -217,7 +217,6 @@ library , lsp-types >=2.0.2.0 , megaparsec , memory - , monoidal-containers , mtl , network , network-simple @@ -360,7 +359,6 @@ executable transcripts , lsp-types >=2.0.2.0 , megaparsec , memory - , monoidal-containers , mtl , network , network-simple @@ -511,7 +509,6 @@ test-suite cli-tests , lsp-types >=2.0.2.0 , megaparsec , memory - , monoidal-containers , mtl , network , network-simple