{-# LANGUAGE RecordWildCards #-}

module Unison.LSP.FileAnalysis
  ( checkFileByUri,
    checkFileContents,
    getFileAnalysis,
    ppedForFile,
    getFileSummary,
    ppedForFileHelper,
    fileAnalysisWorker,
    getFileDefLocations,
    getFileNames,
    analyseNotes,
  )
where

import Control.Lens
import Control.Monad.Reader
import Crypto.Random qualified as Random
import Data.Align (alignWith)
import Data.Align qualified as Align
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
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.These
import Data.Zip qualified as Zip
import Language.LSP.Protocol.Lens (HasCodeAction (codeAction), HasIsPreferred (isPreferred), HasRange (range), HasUri (uri))
import Language.LSP.Protocol.Lens qualified as LSPTypes
import Language.LSP.Protocol.Types
  ( Diagnostic,
    Position,
    Range,
    TextDocumentIdentifier (TextDocumentIdentifier),
    Uri (getUri),
  )
import Unison.ABT qualified as ABT
import Unison.Cli.TypeCheck (computeTypecheckingEnvironment)
import Unison.Cli.UniqueTypeGuidLookup qualified as Cli
import Unison.Codebase qualified as Codebase
import Unison.DataDeclaration qualified as DD
import Unison.Debug qualified as Debug
import Unison.FileParsers (ShouldUseTndr (..))
import Unison.FileParsers qualified as FileParsers
import Unison.KindInference.Error qualified as KindInference
import Unison.LSP.Conversions
import Unison.LSP.Conversions qualified as Cv
import Unison.LSP.Diagnostics (DiagnosticSeverity (..), mkDiagnostic, reportDiagnostics)
import Unison.LSP.FileAnalysis.UnusedBindings qualified as UnusedBindings
import Unison.LSP.Orphans ()
import Unison.LSP.Types
import Unison.LSP.VFS qualified as VFS
import Unison.Name (Name)
import Unison.Names (Names)
import Unison.Names qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.Parsers qualified as Parsers
import Unison.Pattern qualified as Pattern
import Unison.Prelude
import Unison.PrettyPrintEnv (PrettyPrintEnv)
import Unison.PrettyPrintEnv qualified as PPE
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.PrintError qualified as PrintError
import Unison.Referent qualified as Referent
import Unison.Result (Note)
import Unison.Result qualified as Result
import Unison.Symbol (Symbol)
import Unison.Syntax.HashQualifiedPrime qualified as HQ' (toText)
import Unison.Syntax.Lexer.Unison qualified as L
import Unison.Syntax.Name qualified as Name
import Unison.Syntax.Parser qualified as Parser
import Unison.Syntax.TypePrinter qualified as TypePrinter
import Unison.Term qualified as Term
import Unison.Typechecker qualified as Typechecker
import Unison.Typechecker.Context qualified as Context
import Unison.Typechecker.TypeError qualified as TypeError
import Unison.UnisonFile qualified as UF
import Unison.UnisonFile.Names qualified as UF
import Unison.UnisonFile.Summary (FileSummary (..), fileDefLocations)
import Unison.UnisonFile.Summary qualified as FileSummary
import Unison.Util.Monoid (foldMapM)
import Unison.Util.Pretty qualified as Pretty
import Unison.Util.Relation qualified as R1
import Unison.Var qualified as Var
import UnliftIO.STM
import Witherable

-- | Lex, parse, and typecheck a file using a VFS URI
checkFileByUri :: (HasUri d Uri, Lspish m) => d -> m (Maybe FileAnalysis)
checkFileByUri :: forall d (m :: * -> *).
(HasUri d Uri, Lspish m) =>
d -> m (Maybe FileAnalysis)
checkFileByUri d
doc = MaybeT m FileAnalysis -> m (Maybe FileAnalysis)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
  let fileUri :: Uri
fileUri = d
doc d -> Getting Uri d Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri d Uri
forall s a. HasUri s a => Lens' s a
Lens' d Uri
uri
  (fileVersion, contents) <- Uri -> MaybeT m (FileVersion, Text)
forall (m :: * -> *).
Lspish m =>
Uri -> MaybeT m (FileVersion, Text)
VFS.getFileContents Uri
fileUri
  let sourceName = Uri -> Text
getUri (Uri -> Text) -> Uri -> Text
forall a b. (a -> b) -> a -> b
$ Uri
fileUri
  checkFileContents fileUri sourceName fileVersion contents

-- | Lex, parse, and typecheck a file.
-- This is split off for easier testing without needing to mock the VFS.
checkFileContents :: (Lspish m) => Uri -> Text -> FileVersion -> Text -> MaybeT m FileAnalysis
checkFileContents :: forall (m :: * -> *).
Lspish m =>
Uri -> Text -> FileVersion -> Text -> MaybeT m FileAnalysis
checkFileContents Uri
fileUri Text
sourceName FileVersion
fileVersion Text
contents = do
  pp <- m ProjectPath -> MaybeT m ProjectPath
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ProjectPath
forall (m :: * -> *). Lspish m => m ProjectPath
getCurrentProjectPath
  parseNames <- lift getCurrentNames
  let lexedSource@(srcText, tokens) = (contents, L.lexer (Text.unpack sourceName) (Text.unpack contents))
  let ambientAbilities = []
  cb <- asks codebase
  let generateUniqueName = SystemDRG -> UniqueName
forall gen. DRG gen => gen -> UniqueName
Parser.uniqueBase32Namegen (SystemDRG -> UniqueName) -> IO SystemDRG -> IO UniqueName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemDRG
Random.getSystemDRG
  uniqueName <- liftIO generateUniqueName
  let parsingEnv =
        Parser.ParsingEnv
          { uniqueNames :: UniqueName
uniqueNames = UniqueName
uniqueName,
            uniqueTypeGuid :: Name -> Transaction (Maybe Text)
uniqueTypeGuid = ProjectPath -> Name -> Transaction (Maybe Text)
Cli.loadUniqueTypeGuid ProjectPath
pp,
            names :: Names
names = Names
parseNames,
            maybeNamespace :: Maybe Name
maybeNamespace = Maybe Name
forall a. Maybe a
Nothing,
            localNamespacePrefixedTypesAndConstructors :: Names
localNamespacePrefixedTypesAndConstructors = Names
forall a. Monoid a => a
mempty
          }
  (localBindingInfo, 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 Seq (Note Symbol Ann)
parsingNotes Maybe (UnisonFile Symbol Ann)
Nothing -> (IntervalMap Position (Type Symbol Ann, Range),
 Seq (Note Symbol Ann), Maybe (UnisonFile Symbol Ann),
 Maybe (TypecheckedUnisonFile Symbol Ann))
-> Transaction
     (IntervalMap Position (Type Symbol Ann, Range),
      Seq (Note Symbol Ann), Maybe (UnisonFile Symbol Ann),
      Maybe (TypecheckedUnisonFile Symbol Ann))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntervalMap Position (Type Symbol Ann, Range)
forall a. Monoid a => a
mempty, Seq (Note Symbol Ann)
parsingNotes, Maybe (UnisonFile Symbol Ann)
forall a. Maybe a
Nothing, Maybe (TypecheckedUnisonFile Symbol Ann)
forall a. Maybe a
Nothing)
          Result.Result Seq (Note Symbol Ann)
_ (Just UnisonFile Symbol Ann
parsedFile) -> do
            typecheckingEnv <- ShouldUseTndr Transaction
-> Codebase IO Symbol Ann
-> [Type Symbol Ann]
-> UnisonFile Symbol Ann
-> Transaction (Env Symbol Ann)
computeTypecheckingEnvironment (ParsingEnv Transaction -> ShouldUseTndr Transaction
forall (m :: * -> *). ParsingEnv m -> ShouldUseTndr m
ShouldUseTndr'Yes ParsingEnv Transaction
parsingEnv) Codebase IO Symbol Ann
cb [Type Symbol Ann]
forall a. [a]
ambientAbilities UnisonFile Symbol Ann
parsedFile
            let Result.Result typecheckingNotes maybeTypecheckedFile = FileParsers.synthesizeFile typecheckingEnv parsedFile

            symbolInfo <-
              typecheckingNotes
                & Foldable.toList
                & reverse -- Type notes that come later in typechecking have more information filled in.
                & foldMap \case
                  Result.TypeInfo (Context.VarBinding Symbol
v Ann
loc Type Symbol Ann
typ) ->
                    Ann -> Maybe Range
annToRange Ann
loc
                      Maybe Range
-> (Maybe Range -> Map Symbol (Type Symbol Ann, Range))
-> Map Symbol (Type Symbol Ann, Range)
forall a b. a -> (a -> b) -> b
& (Range -> Map Symbol (Type Symbol Ann, Range))
-> Maybe Range -> Map Symbol (Type Symbol Ann, Range)
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \Range
definitionSite -> Symbol
-> (Type Symbol Ann, Range) -> Map Symbol (Type Symbol Ann, Range)
forall k a. k -> a -> Map k a
Map.singleton Symbol
v (Type Symbol Ann
typ, Range
definitionSite)
                  Note Symbol Ann
_ -> Map Symbol (Type Symbol Ann, Range)
forall a. Monoid a => a
mempty
                & pure

            let localBindingInfo :: (IntervalMap Position (Context.Type Symbol Ann, Range)) =
                  typecheckingNotes
                    & Foldable.toList
                    & reverse -- Type notes that come later in typechecking have more information filled in.
                    & foldMap \case
                      Result.TypeInfo (Context.VarBinding Symbol
_v Ann
loc Type Symbol Ann
typ) -> do
                        ( ((Interval Position -> Range -> (Interval Position, Range))
-> Maybe (Interval Position)
-> Maybe Range
-> Maybe (Interval Position, Range)
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Ann -> Maybe (Interval Position)
annToInterval Ann
loc) (Ann -> Maybe Range
annToRange Ann
loc))
                            Maybe (Interval Position, Range)
-> (Maybe (Interval Position, Range)
    -> IntervalMap Position (Type Symbol Ann, Range))
-> IntervalMap Position (Type Symbol Ann, Range)
forall a b. a -> (a -> b) -> b
& ((Interval Position, Range)
 -> IntervalMap Position (Type Symbol Ann, Range))
-> Maybe (Interval Position, Range)
-> IntervalMap Position (Type Symbol Ann, Range)
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \(Interval Position
interval, Range
definitionSite) -> (Interval Position
-> (Type Symbol Ann, Range)
-> IntervalMap Position (Type Symbol Ann, Range)
forall k v. k -> v -> IntervalMap k v
IM.singleton Interval Position
interval (Type Symbol Ann
typ, Range
definitionSite))
                          )
                      Result.TypeInfo (Context.VarMention Symbol
v Ann
loc) -> do
                        case Symbol
-> Map Symbol (Type Symbol Ann, Range)
-> Maybe (Type Symbol Ann, Range)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
v Map Symbol (Type Symbol Ann, Range)
symbolInfo of
                          Just (Type Symbol Ann
typ, Range
definitionSite) ->
                            ((Ann -> Maybe (Interval Position)
annToInterval Ann
loc) Maybe (Interval Position)
-> (Maybe (Interval Position)
    -> IntervalMap Position (Type Symbol Ann, Range))
-> IntervalMap Position (Type Symbol Ann, Range)
forall a b. a -> (a -> b) -> b
& (Interval Position
 -> IntervalMap Position (Type Symbol Ann, Range))
-> Maybe (Interval Position)
-> IntervalMap Position (Type Symbol Ann, Range)
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \Interval Position
interval -> (Interval Position
-> (Type Symbol Ann, Range)
-> IntervalMap Position (Type Symbol Ann, Range)
forall k v. k -> v -> IntervalMap k v
IM.singleton Interval Position
interval (Type Symbol Ann
typ, Range
definitionSite)))
                          Maybe (Type Symbol Ann, Range)
_ -> IntervalMap Position (Type Symbol Ann, Range)
forall a. Monoid a => a
mempty
                      Note Symbol Ann
_ -> IntervalMap Position (Type Symbol Ann, Range)
forall a. Monoid a => a
mempty
            pure (localBindingInfo, typecheckingNotes, Just parsedFile, maybeTypecheckedFile)

  filePPED <- ppedForFileHelper parsedFile typecheckedFile
  (errDiagnostics, codeActions) <- analyseFile fileUri srcText filePPED notes
  let codeActionRanges =
        [RangedCodeAction]
codeActions
          [RangedCodeAction]
-> ([RangedCodeAction] -> [(Range, CodeAction)])
-> [(Range, CodeAction)]
forall a b. a -> (a -> b) -> b
& (RangedCodeAction -> [(Range, CodeAction)])
-> [RangedCodeAction] -> [(Range, CodeAction)]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(RangedCodeAction {[Range]
_codeActionRanges :: [Range]
_codeActionRanges :: RangedCodeAction -> [Range]
_codeActionRanges, CodeAction
_codeAction :: CodeAction
_codeAction :: RangedCodeAction -> CodeAction
_codeAction}) -> (,CodeAction
_codeAction) (Range -> (Range, CodeAction)) -> [Range] -> [(Range, CodeAction)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Range]
_codeActionRanges)
          [(Range, CodeAction)]
-> ([(Range, CodeAction)] -> IntervalMap Position [CodeAction])
-> IntervalMap Position [CodeAction]
forall a b. a -> (a -> b) -> b
& [(Range, CodeAction)] -> IntervalMap Position [CodeAction]
forall (f :: * -> *) a.
Foldable f =>
f (Range, a) -> IntervalMap Position [a]
toRangeMap
  let typeSignatureHints = Map Symbol TypeSignatureHint
-> Maybe (Map Symbol TypeSignatureHint)
-> Map Symbol TypeSignatureHint
forall a. a -> Maybe a -> a
fromMaybe Map Symbol TypeSignatureHint
forall a. Monoid a => a
mempty (UnisonFile Symbol Ann
-> TypecheckedUnisonFile Symbol Ann -> Map Symbol TypeSignatureHint
mkTypeSignatureHints (UnisonFile Symbol Ann
 -> TypecheckedUnisonFile Symbol Ann
 -> Map Symbol TypeSignatureHint)
-> Maybe (UnisonFile Symbol Ann)
-> Maybe
     (TypecheckedUnisonFile Symbol Ann -> Map Symbol TypeSignatureHint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (UnisonFile Symbol Ann)
parsedFile Maybe
  (TypecheckedUnisonFile Symbol Ann -> Map Symbol TypeSignatureHint)
-> Maybe (TypecheckedUnisonFile Symbol Ann)
-> Maybe (Map Symbol TypeSignatureHint)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile)
  let documentSymbols = [UDocumentSymbol] -> Maybe [UDocumentSymbol] -> [UDocumentSymbol]
forall a. a -> Maybe a -> a
fromMaybe [UDocumentSymbol]
forall a. Monoid a => a
mempty (UnisonFile Symbol Ann
-> Maybe (TypecheckedUnisonFile Symbol Ann) -> [UDocumentSymbol]
mkDocumentSymbols (UnisonFile Symbol Ann
 -> Maybe (TypecheckedUnisonFile Symbol Ann) -> [UDocumentSymbol])
-> Maybe (UnisonFile Symbol Ann)
-> Maybe
     (Maybe (TypecheckedUnisonFile Symbol Ann) -> [UDocumentSymbol])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (UnisonFile Symbol Ann)
parsedFile Maybe
  (Maybe (TypecheckedUnisonFile Symbol Ann) -> [UDocumentSymbol])
-> Maybe (Maybe (TypecheckedUnisonFile Symbol Ann))
-> Maybe [UDocumentSymbol]
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (TypecheckedUnisonFile Symbol Ann)
-> Maybe (Maybe (TypecheckedUnisonFile Symbol Ann))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile)
  let fileSummary = Maybe (UnisonFile Symbol Ann)
-> Maybe (TypecheckedUnisonFile Symbol Ann) -> Maybe FileSummary
FileSummary.mkFileSummary Maybe (UnisonFile Symbol Ann)
parsedFile Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile
  let unusedBindingDiagnostics = Maybe FileSummary
fileSummary Maybe FileSummary
-> Getting (Endo [Diagnostic]) (Maybe FileSummary) Diagnostic
-> [Diagnostic]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (FileSummary -> Const (Endo [Diagnostic]) FileSummary)
-> Maybe FileSummary
-> Const (Endo [Diagnostic]) (Maybe FileSummary)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((FileSummary -> Const (Endo [Diagnostic]) FileSummary)
 -> Maybe FileSummary
 -> Const (Endo [Diagnostic]) (Maybe FileSummary))
-> ((Diagnostic -> Const (Endo [Diagnostic]) Diagnostic)
    -> FileSummary -> Const (Endo [Diagnostic]) FileSummary)
-> Getting (Endo [Diagnostic]) (Maybe FileSummary) Diagnostic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileSummary
 -> Map
      Symbol
      (Ann, Maybe TypeReferenceId, Term Symbol Ann,
       Maybe (Type Symbol Ann)))
-> Optic'
     (->)
     (Const (Endo [Diagnostic]))
     FileSummary
     (Map
        Symbol
        (Ann, Maybe TypeReferenceId, Term Symbol Ann,
         Maybe (Type Symbol Ann)))
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to FileSummary
-> Map
     Symbol
     (Ann, Maybe TypeReferenceId, Term Symbol Ann,
      Maybe (Type Symbol Ann))
termsBySymbol Optic'
  (->)
  (Const (Endo [Diagnostic]))
  FileSummary
  (Map
     Symbol
     (Ann, Maybe TypeReferenceId, Term Symbol Ann,
      Maybe (Type Symbol Ann)))
-> ((Diagnostic -> Const (Endo [Diagnostic]) Diagnostic)
    -> Map
         Symbol
         (Ann, Maybe TypeReferenceId, Term Symbol Ann,
          Maybe (Type Symbol Ann))
    -> Const
         (Endo [Diagnostic])
         (Map
            Symbol
            (Ann, Maybe TypeReferenceId, Term Symbol Ann,
             Maybe (Type Symbol Ann))))
-> (Diagnostic -> Const (Endo [Diagnostic]) Diagnostic)
-> FileSummary
-> Const (Endo [Diagnostic]) FileSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Ann, Maybe TypeReferenceId, Term Symbol Ann,
  Maybe (Type Symbol Ann))
 -> Const
      (Endo [Diagnostic])
      (Ann, Maybe TypeReferenceId, Term Symbol Ann,
       Maybe (Type Symbol Ann)))
-> Map
     Symbol
     (Ann, Maybe TypeReferenceId, Term Symbol Ann,
      Maybe (Type Symbol Ann))
-> Const
     (Endo [Diagnostic])
     (Map
        Symbol
        (Ann, Maybe TypeReferenceId, Term Symbol Ann,
         Maybe (Type Symbol Ann)))
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int
  (Map
     Symbol
     (Ann, Maybe TypeReferenceId, Term Symbol Ann,
      Maybe (Type Symbol Ann)))
  (Ann, Maybe TypeReferenceId, Term Symbol Ann,
   Maybe (Type Symbol Ann))
folded (((Ann, Maybe TypeReferenceId, Term Symbol Ann,
   Maybe (Type Symbol Ann))
  -> Const
       (Endo [Diagnostic])
       (Ann, Maybe TypeReferenceId, Term Symbol Ann,
        Maybe (Type Symbol Ann)))
 -> Map
      Symbol
      (Ann, Maybe TypeReferenceId, Term Symbol Ann,
       Maybe (Type Symbol Ann))
 -> Const
      (Endo [Diagnostic])
      (Map
         Symbol
         (Ann, Maybe TypeReferenceId, Term Symbol Ann,
          Maybe (Type Symbol Ann))))
-> ((Diagnostic -> Const (Endo [Diagnostic]) Diagnostic)
    -> (Ann, Maybe TypeReferenceId, Term Symbol Ann,
        Maybe (Type Symbol Ann))
    -> Const
         (Endo [Diagnostic])
         (Ann, Maybe TypeReferenceId, Term Symbol Ann,
          Maybe (Type Symbol Ann)))
-> (Diagnostic -> Const (Endo [Diagnostic]) Diagnostic)
-> Map
     Symbol
     (Ann, Maybe TypeReferenceId, Term Symbol Ann,
      Maybe (Type Symbol Ann))
-> Const
     (Endo [Diagnostic])
     (Map
        Symbol
        (Ann, Maybe TypeReferenceId, Term Symbol Ann,
         Maybe (Type Symbol Ann)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Ann, Maybe TypeReferenceId, Term Symbol Ann,
  Maybe (Type Symbol Ann))
 -> [Diagnostic])
-> Fold
     (Ann, Maybe TypeReferenceId, Term Symbol Ann,
      Maybe (Type Symbol Ann))
     Diagnostic
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding (\(Ann
_topLevelAnn, Maybe TypeReferenceId
_refId, Term Symbol Ann
trm, Maybe (Type Symbol Ann)
_type) -> Uri -> Term Symbol Ann -> [Diagnostic]
UnusedBindings.analyseTerm Uri
fileUri Term Symbol Ann
trm)
  let tokenMap = [Token Lexeme] -> IntervalMap (Interval Position) Lexeme
getTokenMap [Token Lexeme]
tokens
  conflictWarningDiagnostics <-
    fold <$> for fileSummary \FileSummary
fs ->
      Uri -> FileSummary -> MaybeT m [Diagnostic]
forall (m :: * -> *).
Lspish m =>
Uri -> FileSummary -> m [Diagnostic]
computeConflictWarningDiagnostics Uri
fileUri FileSummary
fs
  let diagnosticRanges =
        ([Diagnostic]
errDiagnostics [Diagnostic] -> [Diagnostic] -> [Diagnostic]
forall a. Semigroup a => a -> a -> a
<> [Diagnostic]
conflictWarningDiagnostics [Diagnostic] -> [Diagnostic] -> [Diagnostic]
forall a. Semigroup a => a -> a -> a
<> [Diagnostic]
unusedBindingDiagnostics)
          [Diagnostic]
-> ([Diagnostic] -> [(Range, Diagnostic)]) -> [(Range, Diagnostic)]
forall a b. a -> (a -> b) -> b
& (Diagnostic -> (Range, Diagnostic))
-> [Diagnostic] -> [(Range, Diagnostic)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Diagnostic
d -> (Diagnostic
d Diagnostic -> Getting Range Diagnostic Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range Diagnostic Range
forall s a. HasRange s a => Lens' s a
Lens' Diagnostic Range
range, Diagnostic
d))
          [(Range, Diagnostic)]
-> ([(Range, Diagnostic)] -> IntervalMap Position [Diagnostic])
-> IntervalMap Position [Diagnostic]
forall a b. a -> (a -> b) -> b
& [(Range, Diagnostic)] -> IntervalMap Position [Diagnostic]
forall (f :: * -> *) a.
Foldable f =>
f (Range, a) -> IntervalMap Position [a]
toRangeMap
  let fileAnalysis =
        FileAnalysis
          { diagnostics :: IntervalMap Position [Diagnostic]
diagnostics = IntervalMap Position [Diagnostic]
diagnosticRanges,
            codeActions :: IntervalMap Position [CodeAction]
codeActions = IntervalMap Position [CodeAction]
codeActionRanges,
            Maybe FileSummary
fileSummary :: Maybe FileSummary
fileSummary :: Maybe FileSummary
fileSummary,
            Map Symbol TypeSignatureHint
typeSignatureHints :: Map Symbol TypeSignatureHint
typeSignatureHints :: Map Symbol TypeSignatureHint
typeSignatureHints,
            Uri
fileUri :: Uri
fileUri :: Uri
fileUri,
            FileVersion
fileVersion :: FileVersion
fileVersion :: FileVersion
fileVersion,
            (Text, [Token Lexeme])
lexedSource :: (Text, [Token Lexeme])
lexedSource :: (Text, [Token Lexeme])
lexedSource,
            IntervalMap (Interval Position) Lexeme
tokenMap :: IntervalMap (Interval Position) Lexeme
tokenMap :: IntervalMap (Interval Position) Lexeme
tokenMap,
            Maybe (UnisonFile Symbol Ann)
parsedFile :: Maybe (UnisonFile Symbol Ann)
parsedFile :: Maybe (UnisonFile Symbol Ann)
parsedFile,
            Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile :: Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile :: Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile,
            Seq (Note Symbol Ann)
notes :: Seq (Note Symbol Ann)
notes :: Seq (Note Symbol Ann)
notes,
            IntervalMap Position (Type Symbol Ann, Range)
localBindingInfo :: IntervalMap Position (Type Symbol Ann, Range)
localBindingInfo :: IntervalMap Position (Type Symbol Ann, Range)
localBindingInfo,
            [UDocumentSymbol]
documentSymbols :: [UDocumentSymbol]
documentSymbols :: [UDocumentSymbol]
documentSymbols
          }
  pure fileAnalysis

-- | Get the location of user defined definitions within the file
getFileDefLocations :: Uri -> MaybeT Lsp (Map Symbol (Set Ann))
getFileDefLocations :: Uri -> MaybeT Lsp (Map Symbol (Set Ann))
getFileDefLocations Uri
uri = do
  FileSummary -> Map Symbol (Set Ann)
fileDefLocations (FileSummary -> Map Symbol (Set Ann))
-> MaybeT Lsp FileSummary -> MaybeT Lsp (Map Symbol (Set Ann))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Uri -> MaybeT Lsp FileSummary
forall (m :: * -> *). Lspish m => Uri -> MaybeT m FileSummary
getFileSummary Uri
uri

fileAnalysisWorker :: Lsp ()
fileAnalysisWorker :: Lsp ()
fileAnalysisWorker = Lsp (Map Uri ()) -> Lsp ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
  dirtyFilesV <- (Env -> TVar (Set Uri)) -> Lsp (TVar (Set Uri))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar (Set Uri)
dirtyFilesVar
  checkedFilesV <- asks checkedFilesVar
  -- We may want to debounce this if it typechecks too eagerly,
  -- but typechecking is pretty fast right now when scratch files are small
  dirtyFileIDs <- atomically $ do
    dirty <- readTVar dirtyFilesV
    writeTVar dirtyFilesV mempty
    guard $ not $ null dirty
    pure dirty
  freshlyCheckedFiles <-
    Map.fromList <$> forMaybe (toList dirtyFileIDs) \Uri
docUri -> MaybeT Lsp (Uri, FileAnalysis) -> Lsp (Maybe (Uri, FileAnalysis))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
      fileInfo <- Lsp (Maybe FileAnalysis) -> MaybeT Lsp FileAnalysis
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (TextDocumentIdentifier -> Lsp (Maybe FileAnalysis)
forall d (m :: * -> *).
(HasUri d Uri, Lspish m) =>
d -> m (Maybe FileAnalysis)
checkFileByUri (TextDocumentIdentifier -> Lsp (Maybe FileAnalysis))
-> TextDocumentIdentifier -> Lsp (Maybe FileAnalysis)
forall a b. (a -> b) -> a -> b
$ Uri -> TextDocumentIdentifier
TextDocumentIdentifier Uri
docUri)
      pure (docUri, fileInfo)
  Debug.debugM Debug.LSP "Freshly Typechecked " (Map.toList freshlyCheckedFiles)
  -- Overwrite any files we successfully checked
  atomically $ do
    checkedFiles <- readTVar checkedFilesV
    let zipper = \case
          These TMVar a
mvar a
new -> TMVar a -> STM (Maybe a)
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar a
mvar STM (Maybe a) -> STM () -> STM ()
forall a b. STM a -> STM b -> STM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TMVar a -> a -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar a
mvar a
new STM () -> STM (TMVar a) -> STM (TMVar a)
forall a b. STM a -> STM b -> STM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TMVar a -> STM (TMVar a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMVar a
mvar
          This TMVar a
mvar -> TMVar a -> STM (TMVar a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMVar a
mvar
          That a
new -> a -> STM (TMVar a)
forall a. a -> STM (TMVar a)
newTMVar a
new
    newCheckedFiles <- sequenceA $ alignWith zipper checkedFiles freshlyCheckedFiles
    writeTVar checkedFilesV newCheckedFiles
  for freshlyCheckedFiles \(FileAnalysis {Uri
fileUri :: FileAnalysis -> Uri
fileUri :: Uri
fileUri, FileVersion
fileVersion :: FileAnalysis -> FileVersion
fileVersion :: FileVersion
fileVersion, IntervalMap Position [Diagnostic]
diagnostics :: FileAnalysis -> IntervalMap Position [Diagnostic]
diagnostics :: IntervalMap Position [Diagnostic]
diagnostics}) -> do
    Uri -> Maybe FileVersion -> [Diagnostic] -> Lsp ()
forall (f :: * -> *).
Foldable f =>
Uri -> Maybe FileVersion -> f Diagnostic -> Lsp ()
reportDiagnostics Uri
fileUri (FileVersion -> Maybe FileVersion
forall a. a -> Maybe a
Just FileVersion
fileVersion) ([Diagnostic] -> Lsp ()) -> [Diagnostic] -> Lsp ()
forall a b. (a -> b) -> a -> b
$ IntervalMap Position [Diagnostic] -> [Diagnostic]
forall m. Monoid m => IntervalMap (Interval Position) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold IntervalMap Position [Diagnostic]
diagnostics

analyseFile :: (Lspish m) => (Foldable f) => Uri -> Text -> PPED.PrettyPrintEnvDecl -> f (Note Symbol Ann) -> m ([Diagnostic], [RangedCodeAction])
analyseFile :: forall (m :: * -> *) (f :: * -> *).
(Lspish m, Foldable f) =>
Uri
-> Text
-> PrettyPrintEnvDecl
-> f (Note Symbol Ann)
-> m ([Diagnostic], [RangedCodeAction])
analyseFile Uri
fileUri Text
srcText PrettyPrintEnvDecl
pped f (Note Symbol Ann)
notes = do
  let ppe :: PrettyPrintEnv
ppe = PrettyPrintEnvDecl -> PrettyPrintEnv
PPED.suffixifiedPPE PrettyPrintEnvDecl
pped
  Env {codebase} <- m Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  (noteDiags, noteActions) <- analyseNotes codebase fileUri ppe (Text.unpack srcText) notes
  pure (noteDiags, noteActions)

-- | Returns diagnostics which show a warning diagnostic when editing a term that's conflicted in the
-- codebase.
computeConflictWarningDiagnostics :: (Lspish m) => Uri -> FileSummary -> m [Diagnostic]
computeConflictWarningDiagnostics :: forall (m :: * -> *).
Lspish m =>
Uri -> FileSummary -> m [Diagnostic]
computeConflictWarningDiagnostics Uri
fileUri fileSummary :: FileSummary
fileSummary@FileSummary {Names
fileNames :: Names
fileNames :: FileSummary -> Names
fileNames} = do
  let defLocations :: Map Symbol (Set Ann)
defLocations = FileSummary -> Map Symbol (Set Ann)
fileDefLocations FileSummary
fileSummary
  conflictedNames <- Names -> Names
Names.conflicts (Names -> Names) -> m Names -> m Names
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Names
forall (m :: * -> *). (MonadReader Env m, MonadIO m) => m Names
getCurrentNames
  let locationForName :: Name -> Set Ann
      locationForName Name
name = Maybe (Set Ann) -> Set Ann
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Maybe (Set Ann) -> Set Ann) -> Maybe (Set Ann) -> Set Ann
forall a b. (a -> b) -> a -> b
$ Symbol -> Map Symbol (Set Ann) -> Maybe (Set Ann)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Name -> Symbol
forall v. Var v => Name -> v
Name.toVar Name
name) Map Symbol (Set Ann)
defLocations
  let conflictedTermLocations =
        let fileTerms :: Map Name (Set Referent)
fileTerms = Relation Name Referent -> Map Name (Set Referent)
forall a b. Relation a b -> Map a (Set b)
R1.toMultimap (Names -> Relation Name Referent
Names.terms Names
fileNames)
            conflictedTerms :: Map Name (Set Referent)
conflictedTerms = Relation Name Referent -> Map Name (Set Referent)
forall a b. Relation a b -> Map a (Set b)
R1.toMultimap (Names -> Relation Name Referent
Names.terms Names
conflictedNames)
         in (Name -> Set Referent -> Set Referent -> Set Ann)
-> Map Name (Set Referent)
-> Map Name (Set Referent)
-> Map Name (Set Ann)
forall k a b c.
Ord k =>
(k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWithKey (\Name
name Set Referent
_ Set Referent
_ -> Name -> Set Ann
locationForName Name
name) Map Name (Set Referent)
fileTerms Map Name (Set Referent)
conflictedTerms
  let conflictedTypeLocations =
        let fileTypes :: Map Name (Set TypeReference)
fileTypes = Relation Name TypeReference -> Map Name (Set TypeReference)
forall a b. Relation a b -> Map a (Set b)
R1.toMultimap (Names -> Relation Name TypeReference
Names.types Names
fileNames)
            conflictedTypes :: Map Name (Set TypeReference)
conflictedTypes = Relation Name TypeReference -> Map Name (Set TypeReference)
forall a b. Relation a b -> Map a (Set b)
R1.toMultimap (Names -> Relation Name TypeReference
Names.types Names
conflictedNames)
         in (Name -> Set TypeReference -> Set TypeReference -> Set Ann)
-> Map Name (Set TypeReference)
-> Map Name (Set TypeReference)
-> Map Name (Set Ann)
forall k a b c.
Ord k =>
(k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWithKey (\Name
name Set TypeReference
_ Set TypeReference
_ -> Name -> Set Ann
locationForName Name
name) Map Name (Set TypeReference)
fileTypes Map Name (Set TypeReference)
conflictedTypes
  let toDiagnostics Map Name (Set Ann)
annMap =
        Map Name (Set Ann)
annMap
          Map Name (Set Ann)
-> (Map Name (Set Ann) -> [(Name, Set Ann)]) -> [(Name, Set Ann)]
forall a b. a -> (a -> b) -> b
& Map Name (Set Ann) -> [(Name, Set Ann)]
forall k a. Map k a -> [(k, a)]
Map.toList
          [(Name, Set Ann)]
-> ([(Name, Set Ann)] -> [Diagnostic]) -> [Diagnostic]
forall a b. a -> (a -> b) -> b
& ((Name, Set Ann) -> [Diagnostic])
-> [(Name, Set Ann)] -> [Diagnostic]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \(Name
name, Set Ann
locs) ->
            ((Ann -> Maybe Range) -> [Ann] -> [Range]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe Ann -> Maybe Range
Cv.annToRange ([Ann] -> [Range]) -> (Set Ann -> [Ann]) -> Set Ann -> [Range]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Ann -> [Ann]
forall a. Set a -> [a]
Set.toList (Set Ann -> [Range]) -> Set Ann -> [Range]
forall a b. (a -> b) -> a -> b
$ Set Ann
locs)
              [Range] -> (Range -> Diagnostic) -> [Diagnostic]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Range
range ->
                let msg :: Text
msg = Text
"There are multiple definitions of `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
Name.toText Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` in your namespace; updating this definition will replace them."
                    newRangeEnd :: Position
newRangeEnd =
                      Range
range Range -> Getting Position Range Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position Range Position
forall s a. HasStart s a => Lens' s a
Lens' Range Position
LSPTypes.start
                        Position -> (Position -> Position) -> Position
forall a b. a -> (a -> b) -> b
& (UInt -> Identity UInt) -> Position -> Identity Position
forall s a. HasCharacter s a => Lens' s a
Lens' Position UInt
LSPTypes.character ((UInt -> Identity UInt) -> Position -> Identity Position)
-> UInt -> Position -> Position
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
Text.length (Name -> Text
Name.toText Name
name))
                    newRange :: Range
newRange = Range
range Range -> (Range -> Range) -> Range
forall a b. a -> (a -> b) -> b
& (Position -> Identity Position) -> Range -> Identity Range
forall s a. HasEnd s a => Lens' s a
Lens' Range Position
LSPTypes.end ((Position -> Identity Position) -> Range -> Identity Range)
-> Position -> Range -> Range
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Position
newRangeEnd
                 in Uri
-> Range
-> DiagnosticSeverity
-> [DiagnosticTag]
-> Text
-> [(Text, Range)]
-> Diagnostic
mkDiagnostic
                      Uri
fileUri
                      Range
newRange
                      DiagnosticSeverity
DiagnosticSeverity_Information
                      []
                      Text
msg
                      [(Text, Range)]
forall a. Monoid a => a
mempty
  pure $ toDiagnostics conflictedTermLocations <> toDiagnostics conflictedTypeLocations

getTokenMap :: [L.Token L.Lexeme] -> IM.IntervalMap Position L.Lexeme
getTokenMap :: [Token Lexeme] -> IntervalMap (Interval Position) Lexeme
getTokenMap [Token Lexeme]
tokens =
  [Token Lexeme]
tokens
    [Token Lexeme]
-> ([Token Lexeme] -> [IntervalMap (Interval Position) Lexeme])
-> [IntervalMap (Interval Position) Lexeme]
forall a b. a -> (a -> b) -> b
& (Token Lexeme -> Maybe (IntervalMap (Interval Position) Lexeme))
-> [Token Lexeme] -> [IntervalMap (Interval Position) Lexeme]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe
      ( \Token Lexeme
token ->
          Interval Position
-> Lexeme -> IntervalMap (Interval Position) Lexeme
forall k v. k -> v -> IntervalMap k v
IM.singleton (Interval Position
 -> Lexeme -> IntervalMap (Interval Position) Lexeme)
-> Maybe (Interval Position)
-> Maybe (Lexeme -> IntervalMap (Interval Position) Lexeme)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ann -> Maybe (Interval Position)
annToInterval (Ann -> Maybe (Interval Position))
-> Ann -> Maybe (Interval Position)
forall a b. (a -> b) -> a -> b
$ Token Lexeme -> Ann
forall a. Annotated a => a -> Ann
Parser.ann Token Lexeme
token) Maybe (Lexeme -> IntervalMap (Interval Position) Lexeme)
-> Maybe Lexeme -> Maybe (IntervalMap (Interval Position) Lexeme)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Lexeme -> Maybe Lexeme
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token Lexeme -> Lexeme
forall a. Token a -> a
L.payload Token Lexeme
token)
      )
    [IntervalMap (Interval Position) Lexeme]
-> ([IntervalMap (Interval Position) Lexeme]
    -> IntervalMap (Interval Position) Lexeme)
-> IntervalMap (Interval Position) Lexeme
forall a b. a -> (a -> b) -> b
& [IntervalMap (Interval Position) Lexeme]
-> IntervalMap (Interval Position) Lexeme
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold

analyseNotes ::
  forall f m.
  (Foldable f, MonadIO m) =>
  (Codebase.Codebase IO Symbol Ann) ->
  Uri ->
  PrettyPrintEnv ->
  String ->
  f (Note Symbol Ann) ->
  m ([Diagnostic], [RangedCodeAction])
analyseNotes :: forall (f :: * -> *) (m :: * -> *).
(Foldable f, MonadIO m) =>
Codebase IO Symbol Ann
-> Uri
-> PrettyPrintEnv
-> WatchKind
-> f (Note Symbol Ann)
-> m ([Diagnostic], [RangedCodeAction])
analyseNotes Codebase IO Symbol Ann
codebase Uri
fileUri PrettyPrintEnv
ppe WatchKind
src f (Note Symbol Ann)
notes = do
  (Note Symbol Ann -> m ([Diagnostic], [RangedCodeAction]))
-> f (Note Symbol Ann) -> m ([Diagnostic], [RangedCodeAction])
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM Note Symbol Ann -> m ([Diagnostic], [RangedCodeAction])
go f (Note Symbol Ann)
notes
  where
    go :: Note Symbol Ann -> m ([Diagnostic], [RangedCodeAction])
    go :: Note Symbol Ann -> m ([Diagnostic], [RangedCodeAction])
go Note Symbol Ann
note = case Note Symbol Ann
note of
      Result.TypeError errNote :: ErrorNote Symbol Ann
errNote@(Context.ErrorNote {Cause Symbol Ann
cause :: Cause Symbol Ann
cause :: forall v loc. ErrorNote v loc -> Cause v loc
cause}) -> do
        let typeErr :: TypeError Symbol Ann
typeErr = ErrorNote Symbol Ann -> TypeError Symbol Ann
forall loc v.
(Ord loc, Show loc, Var v) =>
ErrorNote v loc -> TypeError v loc
TypeError.typeErrorFromNote ErrorNote Symbol Ann
errNote
            ranges :: [(Range, [(Text, Range)])]
ranges = case TypeError Symbol Ann
typeErr of
              TypeError.Mismatch {Term Symbol Ann
mismatchSite :: Term Symbol Ann
mismatchSite :: forall v loc. TypeError v loc -> Term v loc
mismatchSite, Type Symbol Ann
foundType :: Type Symbol Ann
foundType :: forall v loc. TypeError v loc -> Type v loc
foundType, Type Symbol Ann
expectedType :: Type Symbol Ann
expectedType :: forall v loc. TypeError v loc -> Type v loc
expectedType}
                | -- If it's a delay mismatch, the error is likely with the block definition (e.g. missing 'do') so we highlight the whole block.
                  Just Either (Type Symbol Ann) (Type Symbol Ann)
_ <- Type Symbol Ann
-> Type Symbol Ann
-> Maybe (Either (Type Symbol Ann) (Type Symbol Ann))
forall v loc.
Var v =>
Type v loc
-> Type v loc -> Maybe (Either (Type v loc) (Type v loc))
Typechecker.isMismatchMissingDelay Type Symbol Ann
foundType Type Symbol Ann
expectedType ->
                    Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
mismatchSite
                -- Otherwise we highlight the leafe nodes of the block
                | Bool
otherwise -> Text -> Term Symbol Ann -> [(Range, [(Text, Range)])]
forall {t} {vt} {at} {ap} {v}.
t -> Term2 vt at ap v Ann -> [(Range, [(t, Range)])]
leafNodeRanges Text
"mismatch" Term Symbol Ann
mismatchSite
              TypeError.BooleanMismatch {Term Symbol Ann
mismatchSite :: forall v loc. TypeError v loc -> Term v loc
mismatchSite :: Term Symbol Ann
mismatchSite} -> Text -> Term Symbol Ann -> [(Range, [(Text, Range)])]
forall {t} {vt} {at} {ap} {v}.
t -> Term2 vt at ap v Ann -> [(Range, [(t, Range)])]
leafNodeRanges Text
"mismatch" Term Symbol Ann
mismatchSite
              TypeError.ExistentialMismatch {Term Symbol Ann
mismatchSite :: forall v loc. TypeError v loc -> Term v loc
mismatchSite :: Term Symbol Ann
mismatchSite} -> Text -> Term Symbol Ann -> [(Range, [(Text, Range)])]
forall {t} {vt} {at} {ap} {v}.
t -> Term2 vt at ap v Ann -> [(Range, [(t, Range)])]
leafNodeRanges Text
"mismatch" Term Symbol Ann
mismatchSite
              TypeError.FunctionUnderApplied {Term Symbol Ann
mismatchSite :: forall v loc. TypeError v loc -> Term v loc
mismatchSite :: Term Symbol Ann
mismatchSite} -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
mismatchSite
              TypeError.FunctionApplication {Term Symbol Ann
f :: Term Symbol Ann
f :: forall v loc. TypeError v loc -> Term v loc
f} -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
f
              TypeError.NotFunctionApplication {Term Symbol Ann
f :: forall v loc. TypeError v loc -> Term v loc
f :: Term Symbol Ann
f} -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
f
              TypeError.AbilityCheckFailure {Ann
abilityCheckFailureSite :: Ann
abilityCheckFailureSite :: forall v loc. TypeError v loc -> loc
abilityCheckFailureSite} -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
abilityCheckFailureSite
              TypeError.AbilitySubtypeFailure {Ann
abilityCheckFailureSite :: forall v loc. TypeError v loc -> loc
abilityCheckFailureSite :: Ann
abilityCheckFailureSite} -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
abilityCheckFailureSite
              TypeError.AbilityEqFailure {Ann
abilityCheckFailureSite :: forall v loc. TypeError v loc -> loc
abilityCheckFailureSite :: Ann
abilityCheckFailureSite} -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
abilityCheckFailureSite
              TypeError.ActionRestrictionFailure {Term Symbol Ann
mismatchSite :: forall v loc. TypeError v loc -> Term v loc
mismatchSite :: Term Symbol Ann
mismatchSite} ->
                Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
mismatchSite
              TypeError.AbilityEqFailureFromAp {Term Symbol Ann
expectedSite :: Term Symbol Ann
expectedSite :: forall v loc. TypeError v loc -> Term v loc
expectedSite, Term Symbol Ann
mismatchSite :: forall v loc. TypeError v loc -> Term v loc
mismatchSite :: Term Symbol Ann
mismatchSite} -> do
                let locs :: [Ann]
locs = [Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
expectedSite, Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
mismatchSite]
                (r, rs) <- [Range] -> [(Range, [Range])]
forall a. [a] -> [(a, [a])]
withNeighbours ([Ann]
locs [Ann] -> (Ann -> [Range]) -> [Range]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ann -> [Range]
aToR)
                pure (r, ("mismatch",) <$> rs)
              TypeError.AbilityInstantiationFailure Symbol
_ [Type Symbol Ann]
_ Term Symbol Ann
site ErrorNote Symbol Ann
_ ->
                Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
site
              TypeError.UnguardedLetRecCycle {[Ann]
cycleLocs :: [Ann]
cycleLocs :: forall v loc. TypeError v loc -> [loc]
cycleLocs} -> do
                let ranges :: [Range]
                    ranges :: [Range]
ranges = [Ann]
cycleLocs [Ann] -> (Ann -> [Range]) -> [Range]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ann -> [Range]
aToR
                (range, cycleRanges) <- [Range] -> [(Range, [Range])]
forall a. [a] -> [(a, [a])]
withNeighbours [Range]
ranges
                pure (range, ("cycle",) <$> cycleRanges)
              TypeError.UnknownType {Ann
typeSite :: Ann
typeSite :: forall v loc. TypeError v loc -> loc
typeSite} -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
typeSite
              TypeError.UnknownTerm {Ann
termSite :: Ann
termSite :: forall v loc. TypeError v loc -> loc
termSite} -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
termSite
              TypeError.DuplicateDefinitions {NonEmpty (Symbol, [Ann])
defns :: NonEmpty (Symbol, [Ann])
defns :: forall v loc. TypeError v loc -> NonEmpty (v, [loc])
defns} -> do
                (_v, locs) <- NonEmpty (Symbol, [Ann]) -> [(Symbol, [Ann])]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Symbol, [Ann])
defns
                (r, rs) <- withNeighbours (locs >>= aToR)
                pure (r, ("duplicate definition",) <$> rs)
              TypeError.RedundantPattern Ann
loc -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc
              TypeError.UncoveredPatterns Ann
loc NonEmpty (Pattern ())
_pats -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc
              TypeError.KindInferenceFailure KindError Symbol Ann
ke -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (KindError Symbol Ann -> Ann
forall loc v. Semigroup loc => KindError v loc -> loc
KindInference.lspLoc KindError Symbol Ann
ke)
              -- These type errors don't have custom type error conversions, but some
              -- still have valid diagnostics.
              TypeError.Other e :: ErrorNote Symbol Ann
e@(Context.ErrorNote {Cause Symbol Ann
cause :: forall v loc. ErrorNote v loc -> Cause v loc
cause :: Cause Symbol Ann
cause}) -> case Cause Symbol Ann
cause of
                Context.PatternArityMismatch Ann
loc Type Symbol Ann
_typ Int
_numArgs -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc
                Context.HandlerOfUnexpectedType Ann
loc Type Symbol Ann
_typ -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc
                Context.TypeMismatch {} -> ErrorNote Symbol Ann -> [(Range, [(Text, Range)])]
forall {a} {m :: * -> *} {b}.
(Show a, Monad m, Alternative m) =>
a -> m b
shouldHaveBeenHandled ErrorNote Symbol Ann
e
                Context.IllFormedType {} -> ErrorNote Symbol Ann -> [(Range, [(Text, Range)])]
forall {a} {m :: * -> *} {b}.
(Show a, Monad m, Alternative m) =>
a -> m b
shouldHaveBeenHandled ErrorNote Symbol Ann
e
                Context.UnknownSymbol Ann
loc Symbol
_ -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc
                Context.UnknownTerm Ann
loc Symbol
_ [Suggestion Symbol Ann]
_ Type Symbol Ann
_ -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc
                Context.AbilityCheckFailure {} -> ErrorNote Symbol Ann -> [(Range, [(Text, Range)])]
forall {a} {m :: * -> *} {b}.
(Show a, Monad m, Alternative m) =>
a -> m b
shouldHaveBeenHandled ErrorNote Symbol Ann
e
                Context.AbilityEqFailure {} -> ErrorNote Symbol Ann -> [(Range, [(Text, Range)])]
forall {a} {m :: * -> *} {b}.
(Show a, Monad m, Alternative m) =>
a -> m b
shouldHaveBeenHandled ErrorNote Symbol Ann
e
                Context.EffectConstructorWrongArgCount {} -> ErrorNote Symbol Ann -> [(Range, [(Text, Range)])]
forall {a} {m :: * -> *} {b}.
(Show a, Monad m, Alternative m) =>
a -> m b
shouldHaveBeenHandled ErrorNote Symbol Ann
e
                Context.MalformedEffectBind {} -> ErrorNote Symbol Ann -> [(Range, [(Text, Range)])]
forall {a} {m :: * -> *} {b}.
(Show a, Monad m, Alternative m) =>
a -> m b
shouldHaveBeenHandled ErrorNote Symbol Ann
e
                Context.DuplicateDefinitions {} -> ErrorNote Symbol Ann -> [(Range, [(Text, Range)])]
forall {a} {m :: * -> *} {b}.
(Show a, Monad m, Alternative m) =>
a -> m b
shouldHaveBeenHandled ErrorNote Symbol Ann
e
                Context.UnguardedLetRecCycle {} -> ErrorNote Symbol Ann -> [(Range, [(Text, Range)])]
forall {a} {m :: * -> *} {b}.
(Show a, Monad m, Alternative m) =>
a -> m b
shouldHaveBeenHandled ErrorNote Symbol Ann
e
                Context.ConcatPatternWithoutConstantLength Ann
loc Type Symbol Ann
_ -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc
                Context.DataEffectMismatch Unknown
_ TypeReference
_ DataDeclaration Symbol Ann
decl -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ DataDeclaration Symbol Ann -> Ann
forall v a. DataDeclaration v a -> a
DD.annotation DataDeclaration Symbol Ann
decl
                Context.UncoveredPatterns Ann
loc NonEmpty (Pattern ())
_ -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc
                Context.RedundantPattern Ann
loc -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc
                Context.InaccessiblePattern Ann
loc -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc
                Context.KindInferenceFailure {} -> ErrorNote Symbol Ann -> [(Range, [(Text, Range)])]
forall {a} {m :: * -> *} {b}.
(Show a, Monad m, Alternative m) =>
a -> m b
shouldHaveBeenHandled ErrorNote Symbol Ann
e
            shouldHaveBeenHandled :: a -> m b
shouldHaveBeenHandled a
e = do
              DebugFlag -> WatchKind -> a -> m ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> WatchKind -> a -> m ()
Debug.debugM DebugFlag
Debug.LSP WatchKind
"This diagnostic should have been handled by a previous case but was not" a
e
              m b
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty
            diags :: [Diagnostic]
diags = Note Symbol Ann -> [(Range, [(Text, Range)])] -> [Diagnostic]
noteDiagnostic Note Symbol Ann
note [(Range, [(Text, Range)])]
ranges
        -- Sort on match accuracy first, then name.
        codeActions <- case Cause Symbol Ann
cause of
          Context.UnknownTerm Ann
_ Symbol
v [Suggestion Symbol Ann]
suggestions Type Symbol Ann
typ -> do
            typeHoleActions <- [Diagnostic] -> Symbol -> Type Symbol Ann -> m [RangedCodeAction]
typeHoleReplacementCodeActions [Diagnostic]
diags Symbol
v Type Symbol Ann
typ
            pure $
              nameResolutionCodeActions diags suggestions
                <> typeHoleActions
          Cause Symbol Ann
_ -> [RangedCodeAction] -> m [RangedCodeAction]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        pure (diags, codeActions)
      Result.NameResolutionFailures {} -> do
        -- TODO: diagnostics/code actions for resolution failures
        ([Diagnostic], [RangedCodeAction])
-> m ([Diagnostic], [RangedCodeAction])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note Symbol Ann -> [(Range, [(Text, Range)])] -> [Diagnostic]
noteDiagnostic Note Symbol Ann
note [(Range, [(Text, Range)])]
forall a. [a]
todoAnnotation, [])
      Result.Parsing Err Symbol
err -> do
        let diags :: [Diagnostic]
diags = do
              (errMsg, ranges) <- WatchKind -> Err Symbol -> [(Pretty ColorText, [Range])]
forall v.
Var v =>
WatchKind -> Err v -> [(Pretty ColorText, [Range])]
PrintError.renderParseErrors WatchKind
src Err Symbol
err
              let txtMsg = Width -> Pretty ColorText -> Text
Pretty.toPlain Width
80 Pretty ColorText
errMsg
              range <- ranges
              pure $ mkDiagnostic fileUri (uToLspRange range) DiagnosticSeverity_Error [] txtMsg []
        -- TODO: Some parsing errors likely have reasonable code actions
        ([Diagnostic], [RangedCodeAction])
-> m ([Diagnostic], [RangedCodeAction])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Diagnostic]
diags, [])
      Result.UnknownSymbol Symbol
_ Ann
loc ->
        ([Diagnostic], [RangedCodeAction])
-> m ([Diagnostic], [RangedCodeAction])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note Symbol Ann -> [(Range, [(Text, Range)])] -> [Diagnostic]
noteDiagnostic Note Symbol Ann
note (Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc), [])
      Result.TypeInfo {} -> ([Diagnostic], [RangedCodeAction])
-> m ([Diagnostic], [RangedCodeAction])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
      Result.CompilerBug CompilerBug Symbol Ann
cbug -> do
        let ranges :: [(Range, [(Text, Range)])]
ranges = case CompilerBug Symbol Ann
cbug of
              Result.TopLevelComponentNotFound Symbol
_ Term Symbol Ann
trm -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
trm
              Result.ResolvedNameNotFound Symbol
_ Ann
loc Name
_ -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange Ann
loc
              Result.TypecheckerBug CompilerBug Symbol Ann
tcbug -> case CompilerBug Symbol Ann
tcbug of
                Context.UnknownDecl Unknown
_un TypeReference
_ref Map TypeReference (DataDeclaration Symbol Ann)
decls -> Map TypeReference (DataDeclaration Symbol Ann)
decls Map TypeReference (DataDeclaration Symbol Ann)
-> (Map TypeReference (DataDeclaration Symbol Ann)
    -> [(Range, [(Text, Range)])])
-> [(Range, [(Text, Range)])]
forall a b. a -> (a -> b) -> b
& (DataDeclaration Symbol Ann -> [(Range, [(Text, Range)])])
-> Map TypeReference (DataDeclaration Symbol Ann)
-> [(Range, [(Text, Range)])]
forall m a. Monoid m => (a -> m) -> Map TypeReference a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \DataDeclaration Symbol Ann
decl -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ DataDeclaration Symbol Ann -> Ann
forall v a. DataDeclaration v a -> a
DD.annotation DataDeclaration Symbol Ann
decl
                Context.UnknownConstructor Unknown
_un ConstructorReference
_gcr DataDeclaration Symbol Ann
decl -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ DataDeclaration Symbol Ann -> Ann
forall v a. DataDeclaration v a -> a
DD.annotation DataDeclaration Symbol Ann
decl
                Context.UndeclaredTermVariable Symbol
_sym Context Symbol Ann
_con -> [(Range, [(Text, Range)])]
forall a. [a]
todoAnnotation
                Context.RetractFailure Element Symbol Ann
_el Context Symbol Ann
_con -> [(Range, [(Text, Range)])]
forall a. [a]
todoAnnotation
                Context.EmptyLetRec Term Symbol Ann
trm -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
trm
                CompilerBug Symbol Ann
Context.PatternMatchFailure -> [(Range, [(Text, Range)])]
forall a. [a]
todoAnnotation
                Context.EffectConstructorHadMultipleEffects Type Symbol Ann
typ -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ Type Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Type Symbol Ann
typ
                Context.FreeVarsInTypeAnnotation Set (TypeVar Symbol Ann)
_set -> [(Range, [(Text, Range)])]
forall a. [a]
todoAnnotation
                Context.UnannotatedReference TypeReference
_ref -> [(Range, [(Text, Range)])]
forall a. [a]
todoAnnotation
                Context.MalformedPattern Pattern Ann
pat -> Ann -> [(Range, [(Text, Range)])]
forall a. Ann -> [(Range, [a])]
singleRange (Ann -> [(Range, [(Text, Range)])])
-> Ann -> [(Range, [(Text, Range)])]
forall a b. (a -> b) -> a -> b
$ Pattern Ann -> Ann
forall loc. Pattern loc -> loc
Pattern.loc Pattern Ann
pat
                Context.UnknownTermReference TypeReference
_ref -> [(Range, [(Text, Range)])]
forall a. [a]
todoAnnotation
                Context.UnknownExistentialVariable Symbol
_sym Context Symbol Ann
_con -> [(Range, [(Text, Range)])]
forall a. [a]
todoAnnotation
                Context.IllegalContextExtension Context Symbol Ann
_con Element Symbol Ann
_el WatchKind
_s -> [(Range, [(Text, Range)])]
forall a. [a]
todoAnnotation
                Context.OtherBug WatchKind
_s -> [(Range, [(Text, Range)])]
forall a. [a]
todoAnnotation
        ([Diagnostic], [RangedCodeAction])
-> m ([Diagnostic], [RangedCodeAction])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note Symbol Ann -> [(Range, [(Text, Range)])] -> [Diagnostic]
noteDiagnostic Note Symbol Ann
note [(Range, [(Text, Range)])]
ranges, [])

    leafNodeRanges :: t -> Term2 vt at ap v Ann -> [(Range, [(t, Range)])]
leafNodeRanges t
label Term2 vt at ap v Ann
mismatchSite = do
      let locs :: [Ann]
locs = Term2 vt at ap v Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation (Term2 vt at ap v Ann -> Ann) -> [Term2 vt at ap v Ann] -> [Ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term2 vt at ap v Ann -> [Term2 vt at ap v Ann]
forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v Ann
mismatchSite
      (r, rs) <- [Range] -> [(Range, [Range])]
forall a. [a] -> [(a, [a])]
withNeighbours ([Ann]
locs [Ann] -> (Ann -> [Range]) -> [Range]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ann -> [Range]
aToR)
      pure (r, (label,) <$> rs)
    -- Diagnostics with this return value haven't been properly configured yet.
    todoAnnotation :: [a]
todoAnnotation = []
    singleRange :: Ann -> [(Range, [a])]
    singleRange :: forall a. Ann -> [(Range, [a])]
singleRange Ann
ann = do
      r <- Ann -> [Range]
aToR Ann
ann
      pure (r, [])

    aToR :: Ann -> [Range]
    aToR :: Ann -> [Range]
aToR = Maybe Range -> [Range]
forall a. Maybe a -> [a]
maybeToList (Maybe Range -> [Range]) -> (Ann -> Maybe Range) -> Ann -> [Range]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> Maybe Range
annToRange
    -- >>> withNeighbours [1, 2, 3, 4]
    -- [(1,[2,3,4]),(2,[1,3,4]),(3,[1,2,4]),(4,[1,2,3])]
    withNeighbours :: [a] -> [(a, [a])]
    withNeighbours :: forall a. [a] -> [(a, [a])]
withNeighbours [] = []
    withNeighbours (a
a : [a]
as) = (a
a, [a]
as) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: (([a] -> [a]) -> (a, [a]) -> (a, [a])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ((a, [a]) -> (a, [a])) -> [(a, [a])] -> [(a, [a])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
withNeighbours [a]
as)
    -- Builds diagnostics for a note, one diagnostic per range.
    noteDiagnostic ::
      Note Symbol Ann ->
      -- All ranges affected by this note, each range may have references to 'related'
      -- ranges.
      -- E.g. a name conflict note might mark each conflicted name, and contain references to the
      -- other conflicted name locations.
      [(Range, [(Text, Range)])] ->
      [Diagnostic]
    noteDiagnostic :: Note Symbol Ann -> [(Range, [(Text, Range)])] -> [Diagnostic]
noteDiagnostic Note Symbol Ann
note [(Range, [(Text, Range)])]
ranges =
      let msg :: Text
msg = Width -> Pretty ColorText -> Text
Pretty.toPlain Width
80 (Pretty ColorText -> Text) -> Pretty ColorText -> Text
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> WatchKind -> Note Symbol Ann -> Pretty ColorText
forall v a.
(Var v, Annotated a, Show a, Ord a) =>
PrettyPrintEnv -> WatchKind -> Note v a -> Pretty ColorText
PrintError.printNoteWithSource PrettyPrintEnv
ppe WatchKind
src Note Symbol Ann
note
       in do
            (range, references) <- [(Range, [(Text, Range)])]
ranges
            pure $ mkDiagnostic fileUri range DiagnosticSeverity_Error [] msg references
    -- Suggest name replacements or qualifications when there's ambiguity
    nameResolutionCodeActions :: [Diagnostic] -> [Context.Suggestion Symbol Ann] -> [RangedCodeAction]
    nameResolutionCodeActions :: [Diagnostic] -> [Suggestion Symbol Ann] -> [RangedCodeAction]
nameResolutionCodeActions [Diagnostic]
diags [Suggestion Symbol Ann]
suggestions = do
      Context.Suggestion {suggestionName, suggestionType, suggestionMatch} <- (Suggestion Symbol Ann -> (Int, Name))
-> [Suggestion Symbol Ann] -> [Suggestion Symbol Ann]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Suggestion Symbol Ann -> (Int, Name)
forall {v} {loc}. Suggestion v loc -> (Int, Name)
nameResolutionSuggestionPriority [Suggestion Symbol Ann]
suggestions
      let prettyType = Width -> PrettyPrintEnv -> Type Symbol Ann -> Text
forall v a. Var v => Width -> PrettyPrintEnv -> Type v a -> Text
TypePrinter.prettyStr Width
0 PrettyPrintEnv
ppe Type Symbol Ann
suggestionType
      let ranges = ([Diagnostic]
diags [Diagnostic]
-> Getting (Endo [Range]) [Diagnostic] Range -> [Range]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Diagnostic -> Const (Endo [Range]) Diagnostic)
-> [Diagnostic] -> Const (Endo [Range]) [Diagnostic]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [Diagnostic] Diagnostic
folded ((Diagnostic -> Const (Endo [Range]) Diagnostic)
 -> [Diagnostic] -> Const (Endo [Range]) [Diagnostic])
-> ((Range -> Const (Endo [Range]) Range)
    -> Diagnostic -> Const (Endo [Range]) Diagnostic)
-> Getting (Endo [Range]) [Diagnostic] Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range -> Const (Endo [Range]) Range)
-> Diagnostic -> Const (Endo [Range]) Diagnostic
forall s a. HasRange s a => Lens' s a
Lens' Diagnostic Range
range)
      let rca = Text -> [Diagnostic] -> [Range] -> RangedCodeAction
rangedCodeAction (Text
"Use " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
Name.toText Name
suggestionName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prettyType) [Diagnostic]
diags [Range]
ranges
      pure $
        rca
          & includeEdits fileUri (Name.toText suggestionName) ranges
          & codeAction . isPreferred ?~ (suggestionMatch == Context.Exact)

    nameResolutionSuggestionPriority :: Suggestion v loc -> (Int, Name)
nameResolutionSuggestionPriority (Context.Suggestion {SuggestionMatch
suggestionMatch :: forall v loc. Suggestion v loc -> SuggestionMatch
suggestionMatch :: SuggestionMatch
suggestionMatch, Name
suggestionName :: forall v loc. Suggestion v loc -> Name
suggestionName :: Name
suggestionName}) = case SuggestionMatch
suggestionMatch of
      SuggestionMatch
Context.Exact -> (Int
0 :: Int, Name
suggestionName)
      SuggestionMatch
Context.RightNameWrongType -> (Int
1, Name
suggestionName)
      SuggestionMatch
Context.SimilarNameRightType -> (Int
2, Name
suggestionName)
      SuggestionMatch
Context.SimilarNameWrongType -> (Int
3, Name
suggestionName)
      SuggestionMatch
Context.WrongNameRightType -> (Int
4, Name
suggestionName)

    -- typeHoleReplacementCodeActions :: Symbol -> _ -> Lsp [a]
    typeHoleReplacementCodeActions :: [Diagnostic] -> Symbol -> Type Symbol Ann -> m [RangedCodeAction]
typeHoleReplacementCodeActions [Diagnostic]
diags Symbol
v Type Symbol Ann
typ
      | Bool -> Bool
not (Symbol -> Bool
isUserBlank Symbol
v) = [RangedCodeAction] -> m [RangedCodeAction]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | Bool
otherwise = do
          let cleanedTyp :: Type Symbol Ann
cleanedTyp = Type Symbol Ann -> Type Symbol Ann
forall v a. Var v => Type v a -> Type v a
Context.generalizeAndUnTypeVar Type Symbol Ann
typ -- TODO: is this right?
          refs <- IO (Set Referent) -> m (Set Referent)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Set Referent) -> m (Set Referent))
-> (Transaction (Set Referent) -> IO (Set Referent))
-> Transaction (Set Referent)
-> m (Set Referent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codebase IO Symbol Ann
-> Transaction (Set Referent) -> IO (Set Referent)
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase (Transaction (Set Referent) -> m (Set Referent))
-> Transaction (Set Referent) -> m (Set Referent)
forall a b. (a -> b) -> a -> b
$ Codebase IO Symbol Ann
-> Type Symbol Ann -> Transaction (Set Referent)
forall v (m :: * -> *) a.
Var v =>
Codebase m v a -> Type v a -> Transaction (Set Referent)
Codebase.termsOfType Codebase IO Symbol Ann
codebase Type Symbol Ann
cleanedTyp
          forMaybe (toList refs) $ \Referent
ref -> MaybeT m RangedCodeAction -> m (Maybe RangedCodeAction)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m RangedCodeAction -> m (Maybe RangedCodeAction))
-> MaybeT m RangedCodeAction -> m (Maybe RangedCodeAction)
forall a b. (a -> b) -> a -> b
$ do
            hqNameSuggestion <- m (Maybe (HashQualified Name)) -> MaybeT m (HashQualified Name)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe (HashQualified Name)) -> MaybeT m (HashQualified Name))
-> (Maybe (HashQualified Name) -> m (Maybe (HashQualified Name)))
-> Maybe (HashQualified Name)
-> MaybeT m (HashQualified Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (HashQualified Name) -> m (Maybe (HashQualified Name))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (HashQualified Name) -> MaybeT m (HashQualified Name))
-> Maybe (HashQualified Name) -> MaybeT m (HashQualified Name)
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> Maybe (HashQualified Name)
PPE.terms PrettyPrintEnv
ppe Referent
ref
            typ <- MaybeT . liftIO . Codebase.runTransaction codebase $ Codebase.getTypeOfReferent codebase ref
            let prettyType = Width -> PrettyPrintEnv -> Type Symbol Ann -> Text
forall v a. Var v => Width -> PrettyPrintEnv -> Type v a -> Text
TypePrinter.prettyStr Width
0 PrettyPrintEnv
ppe Type Symbol Ann
typ
            let txtName = HashQualified Name -> Text
HQ'.toText HashQualified Name
hqNameSuggestion
            let ranges = ([Diagnostic]
diags [Diagnostic]
-> Getting (Endo [Range]) [Diagnostic] Range -> [Range]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Diagnostic -> Const (Endo [Range]) Diagnostic)
-> [Diagnostic] -> Const (Endo [Range]) [Diagnostic]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [Diagnostic] Diagnostic
folded ((Diagnostic -> Const (Endo [Range]) Diagnostic)
 -> [Diagnostic] -> Const (Endo [Range]) [Diagnostic])
-> ((Range -> Const (Endo [Range]) Range)
    -> Diagnostic -> Const (Endo [Range]) Diagnostic)
-> Getting (Endo [Range]) [Diagnostic] Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range -> Const (Endo [Range]) Range)
-> Diagnostic -> Const (Endo [Range]) Diagnostic
forall s a. HasRange s a => Lens' s a
Lens' Diagnostic Range
range)
            let rca = Text -> [Diagnostic] -> [Range] -> RangedCodeAction
rangedCodeAction (Text
"Use " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txtName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prettyType) [Diagnostic]
diags [Range]
ranges
            pure $ includeEdits fileUri txtName ranges rca
    isUserBlank :: Symbol -> Bool
    isUserBlank :: Symbol -> Bool
isUserBlank Symbol
v = case Symbol -> Type
forall v. Var v => v -> Type
Var.typeOf Symbol
v of
      Var.User Text
name -> Text -> Text -> Bool
Text.isPrefixOf Text
"_" Text
name
      Type
_ -> Bool
False

toRangeMap :: (Foldable f) => f (Range, a) -> IntervalMap Position [a]
toRangeMap :: forall (f :: * -> *) a.
Foldable f =>
f (Range, a) -> IntervalMap Position [a]
toRangeMap f (Range, a)
vs =
  ([a] -> [a] -> [a])
-> [(Interval Position, [a])]
-> IntervalMap (Interval Position) [a]
forall k e a.
(Interval k e, Ord k) =>
(a -> a -> a) -> [(k, a)] -> IntervalMap k a
IM.fromListWith [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
(<>) (f (Range, a) -> [(Range, a)]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (Range, a)
vs [(Range, a)]
-> ((Range, a) -> (Interval Position, [a]))
-> [(Interval Position, [a])]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Range
r, a
a) -> (Range -> Interval Position
rangeToInterval Range
r, [a
a]))

getFileAnalysis :: (Lspish m) => Uri -> MaybeT m FileAnalysis
getFileAnalysis :: forall (m :: * -> *). Lspish m => Uri -> MaybeT m FileAnalysis
getFileAnalysis Uri
uri = do
  checkedFilesV <- (Env -> TVar (Map Uri (TMVar FileAnalysis)))
-> MaybeT m (TVar (Map Uri (TMVar FileAnalysis)))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar (Map Uri (TMVar FileAnalysis))
checkedFilesVar
  -- Try to get the file analysis, if there's a var, then read it, waiting if necessary
  -- If there's no var, add one and wait for it to be filled (all Uris should be analyzed
  -- eventually unless theres some bug in the VFS).
  tmvar <- atomically do
    checkedFiles <- readTVar checkedFilesV
    case Map.lookup uri checkedFiles of
      Maybe (TMVar FileAnalysis)
Nothing -> do
        mvar <- STM (TMVar FileAnalysis)
forall a. STM (TMVar a)
newEmptyTMVar
        Debug.debugM Debug.LSP "File analysis requested but none available, waiting for analysis for" uri
        writeTVar checkedFilesV $ Map.insert uri mvar checkedFiles
        pure mvar
      Just TMVar FileAnalysis
mvar -> TMVar FileAnalysis -> STM (TMVar FileAnalysis)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMVar FileAnalysis
mvar
  Debug.debugM Debug.LSP "Waiting on file analysis" uri
  r <- atomically (readTMVar tmvar)
  Debug.debugM Debug.LSP "Got file analysis" uri
  pure r

-- | Build a Names from a file if it's parseable.
--
-- If the file typechecks, generate names from that,
-- otherwise, generate names from the 'parsed' file. Note that the
-- names for a parsed file contains only names for parts of decls, since
-- we don't know references within terms before typechecking due to TDNR.
-- This should be fine though, since those references will all be kept in the
-- ABT as symbols anyways.
--
-- See UF.toNames and UF.typecheckedToNames for more info.
getFileNames :: Uri -> MaybeT Lsp Names
getFileNames :: Uri -> MaybeT Lsp Names
getFileNames Uri
fileUri = do
  FileAnalysis {typecheckedFile = tf, parsedFile = pf} <- Uri -> MaybeT Lsp FileAnalysis
forall (m :: * -> *). Lspish m => Uri -> MaybeT m FileAnalysis
getFileAnalysis Uri
fileUri
  hoistMaybe (fmap UF.typecheckedToNames tf <|> fmap UF.toNames pf)

getFileSummary :: (Lspish m) => Uri -> MaybeT m FileSummary
getFileSummary :: forall (m :: * -> *). Lspish m => Uri -> MaybeT m FileSummary
getFileSummary Uri
uri = do
  FileAnalysis {fileSummary} <- Uri -> MaybeT m FileAnalysis
forall (m :: * -> *). Lspish m => Uri -> MaybeT m FileAnalysis
getFileAnalysis Uri
uri
  MaybeT . pure $ fileSummary

-- TODO memoize per file
ppedForFile :: (Lspish m) => Uri -> m PPED.PrettyPrintEnvDecl
ppedForFile :: forall (m :: * -> *). Lspish m => Uri -> m PrettyPrintEnvDecl
ppedForFile Uri
fileUri = do
  MaybeT m FileAnalysis -> m (Maybe FileAnalysis)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (Uri -> MaybeT m FileAnalysis
forall (m :: * -> *). Lspish m => Uri -> MaybeT m FileAnalysis
getFileAnalysis Uri
fileUri) m (Maybe FileAnalysis)
-> (Maybe FileAnalysis -> m PrettyPrintEnvDecl)
-> m PrettyPrintEnvDecl
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (FileAnalysis {typecheckedFile :: FileAnalysis -> Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile = Maybe (TypecheckedUnisonFile Symbol Ann)
tf, parsedFile :: FileAnalysis -> Maybe (UnisonFile Symbol Ann)
parsedFile = Maybe (UnisonFile Symbol Ann)
uf}) ->
      Maybe (UnisonFile Symbol Ann)
-> Maybe (TypecheckedUnisonFile Symbol Ann) -> m PrettyPrintEnvDecl
forall (m :: * -> *) a.
Lspish m =>
Maybe (UnisonFile Symbol a)
-> Maybe (TypecheckedUnisonFile Symbol a) -> m PrettyPrintEnvDecl
ppedForFileHelper Maybe (UnisonFile Symbol Ann)
uf Maybe (TypecheckedUnisonFile Symbol Ann)
tf
    Maybe FileAnalysis
_ -> Maybe (UnisonFile Symbol (ZonkAny 0))
-> Maybe (TypecheckedUnisonFile Symbol (ZonkAny 0))
-> m PrettyPrintEnvDecl
forall (m :: * -> *) a.
Lspish m =>
Maybe (UnisonFile Symbol a)
-> Maybe (TypecheckedUnisonFile Symbol a) -> m PrettyPrintEnvDecl
ppedForFileHelper Maybe (UnisonFile Symbol (ZonkAny 0))
forall a. Maybe a
Nothing Maybe (TypecheckedUnisonFile Symbol (ZonkAny 0))
forall a. Maybe a
Nothing

ppedForFileHelper :: (Lspish m) => Maybe (UF.UnisonFile Symbol a) -> Maybe (UF.TypecheckedUnisonFile Symbol a) -> m PPED.PrettyPrintEnvDecl
ppedForFileHelper :: forall (m :: * -> *) a.
Lspish m =>
Maybe (UnisonFile Symbol a)
-> Maybe (TypecheckedUnisonFile Symbol a) -> m PrettyPrintEnvDecl
ppedForFileHelper Maybe (UnisonFile Symbol a)
uf Maybe (TypecheckedUnisonFile Symbol a)
tf = do
  codebasePPED <- m PrettyPrintEnvDecl
forall (m :: * -> *). Lspish m => m PrettyPrintEnvDecl
currentPPED
  hashLen <- asks codebase >>= \Codebase IO Symbol Ann
codebase -> IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Codebase IO Symbol Ann -> Transaction Int -> IO Int
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase Transaction Int
Codebase.hashLength)
  pure $ case (uf, tf) of
    (Maybe (UnisonFile Symbol a)
Nothing, Maybe (TypecheckedUnisonFile Symbol a)
Nothing) -> PrettyPrintEnvDecl
codebasePPED
    (Maybe (UnisonFile Symbol a)
_, Just TypecheckedUnisonFile Symbol a
tf) ->
      let fileNames :: Names
fileNames = TypecheckedUnisonFile Symbol a -> Names
forall v a. Var v => TypecheckedUnisonFile v a -> Names
UF.typecheckedToNames TypecheckedUnisonFile Symbol a
tf
          filePPED :: PrettyPrintEnvDecl
filePPED = Namer -> Suffixifier -> PrettyPrintEnvDecl
PPED.makePPED (Int -> Names -> Namer
PPE.hqNamer Int
hashLen Names
fileNames) (Names -> Suffixifier
PPE.suffixifyByHash Names
fileNames)
       in PrettyPrintEnvDecl
filePPED PrettyPrintEnvDecl -> PrettyPrintEnvDecl -> PrettyPrintEnvDecl
`PPED.addFallback` PrettyPrintEnvDecl
codebasePPED
    (Just UnisonFile Symbol a
uf, Maybe (TypecheckedUnisonFile Symbol a)
_) ->
      let fileNames :: Names
fileNames = UnisonFile Symbol a -> Names
forall v a. Var v => UnisonFile v a -> Names
UF.toNames UnisonFile Symbol a
uf
          filePPED :: PrettyPrintEnvDecl
filePPED = Namer -> Suffixifier -> PrettyPrintEnvDecl
PPED.makePPED (Int -> Names -> Namer
PPE.hqNamer Int
hashLen Names
fileNames) (Names -> Suffixifier
PPE.suffixifyByHash Names
fileNames)
       in PrettyPrintEnvDecl
filePPED PrettyPrintEnvDecl -> PrettyPrintEnvDecl -> PrettyPrintEnvDecl
`PPED.addFallback` PrettyPrintEnvDecl
codebasePPED

mkTypeSignatureHints :: UF.UnisonFile Symbol Ann -> UF.TypecheckedUnisonFile Symbol Ann -> Map Symbol TypeSignatureHint
mkTypeSignatureHints :: UnisonFile Symbol Ann
-> TypecheckedUnisonFile Symbol Ann -> Map Symbol TypeSignatureHint
mkTypeSignatureHints UnisonFile Symbol Ann
parsedFile TypecheckedUnisonFile Symbol Ann
typecheckedFile = do
  let symbolsWithoutTypeSigs :: Map Symbol Ann
      symbolsWithoutTypeSigs :: Map Symbol Ann
symbolsWithoutTypeSigs =
        Map Symbol (Ann, Term Symbol Ann)
-> [(Symbol, (Ann, Term Symbol Ann))]
forall k a. Map k a -> [(k, a)]
Map.toList (UnisonFile Symbol Ann -> Map Symbol (Ann, Term Symbol Ann)
forall v a. UnisonFile v a -> Map v (a, Term v a)
UF.terms UnisonFile Symbol Ann
parsedFile)
          [(Symbol, (Ann, Term Symbol Ann))]
-> ([(Symbol, (Ann, Term Symbol Ann))] -> [(Symbol, Ann)])
-> [(Symbol, Ann)]
forall a b. a -> (a -> b) -> b
& ((Symbol, (Ann, Term Symbol Ann)) -> Maybe (Symbol, Ann))
-> [(Symbol, (Ann, Term Symbol Ann))] -> [(Symbol, Ann)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe
            ( \(Symbol
v, (Ann
ann, Term Symbol Ann
trm)) -> do
                -- We only want hints for terms without a user signature
                Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Maybe (Type Symbol Ann) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (Type Symbol Ann) -> Bool)
-> Maybe (Type Symbol Ann) -> Bool
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Maybe (Type Symbol Ann)
forall v a. Term v a -> Maybe (Type v a)
Term.getTypeAnnotation Term Symbol Ann
trm)
                (Symbol, Ann) -> Maybe (Symbol, Ann)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbol
v, Ann
ann)
            )
          [(Symbol, Ann)]
-> ([(Symbol, Ann)] -> Map Symbol Ann) -> Map Symbol Ann
forall a b. a -> (a -> b) -> b
& [(Symbol, Ann)] -> Map Symbol Ann
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      typeHints :: Map Symbol TypeSignatureHint
typeHints =
        TypecheckedUnisonFile Symbol Ann
typecheckedFile
          TypecheckedUnisonFile Symbol Ann
-> (TypecheckedUnisonFile Symbol Ann
    -> Map
         Symbol
         (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
          Type Symbol Ann))
-> Map
     Symbol
     (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
      Type Symbol Ann)
forall a b. a -> (a -> b) -> b
& TypecheckedUnisonFile Symbol Ann
-> Map
     Symbol
     (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
      Type Symbol Ann)
forall v a.
TypecheckedUnisonFile v a
-> Map v (a, TypeReferenceId, Maybe WatchKind, Term v a, Type v a)
UF.hashTermsId
          Map
  Symbol
  (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
   Type Symbol Ann)
-> (Map
      Symbol
      (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
       Type Symbol Ann)
    -> Map
         Symbol
         (Ann,
          (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
           Type Symbol Ann)))
-> Map
     Symbol
     (Ann,
      (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
       Type Symbol Ann))
forall a b. a -> (a -> b) -> b
& Map Symbol Ann
-> Map
     Symbol
     (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
      Type Symbol Ann)
-> Map
     Symbol
     (Ann,
      (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
       Type Symbol Ann))
forall a b. Map Symbol a -> Map Symbol b -> Map Symbol (a, b)
forall (f :: * -> *) a b. Zip f => f a -> f b -> f (a, b)
Zip.zip Map Symbol Ann
symbolsWithoutTypeSigs
          Map
  Symbol
  (Ann,
   (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
    Type Symbol Ann))
-> (Map
      Symbol
      (Ann,
       (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
        Type Symbol Ann))
    -> Map Symbol TypeSignatureHint)
-> Map Symbol TypeSignatureHint
forall a b. a -> (a -> b) -> b
& (Symbol
 -> (Ann,
     (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
      Type Symbol Ann))
 -> Maybe TypeSignatureHint)
-> Map
     Symbol
     (Ann,
      (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
       Type Symbol Ann))
-> Map Symbol TypeSignatureHint
forall a b.
(Symbol -> a -> Maybe b) -> Map Symbol a -> Map Symbol b
forall i (t :: * -> *) a b.
FilterableWithIndex i t =>
(i -> a -> Maybe b) -> t a -> t b
imapMaybe
            ( \Symbol
v (Ann
ann, (Ann
_ann, TypeReferenceId
ref, Maybe WatchKind
_wk, Term Symbol Ann
_trm, Type Symbol Ann
typ)) -> do
                name <- Text -> Maybe Name
Name.parseText (Symbol -> Text
forall v. Var v => v -> Text
Var.name Symbol
v)
                range <- annToRange ann
                let newRangeEnd =
                      Range
range Range -> Getting Position Range Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position Range Position
forall s a. HasStart s a => Lens' s a
Lens' Range Position
LSPTypes.start
                        Position -> (Position -> Position) -> Position
forall a b. a -> (a -> b) -> b
& (UInt -> Identity UInt) -> Position -> Identity Position
forall s a. HasCharacter s a => Lens' s a
Lens' Position UInt
LSPTypes.character ((UInt -> Identity UInt) -> Position -> Identity Position)
-> UInt -> Position -> Position
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
Text.length (Name -> Text
Name.toText Name
name))
                let newRange = Range
range Range -> (Range -> Range) -> Range
forall a b. a -> (a -> b) -> b
& (Position -> Identity Position) -> Range -> Identity Range
forall s a. HasEnd s a => Lens' s a
Lens' Range Position
LSPTypes.end ((Position -> Identity Position) -> Range -> Identity Range)
-> Position -> Range -> Range
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Position
newRangeEnd
                pure $ TypeSignatureHint name (Referent.fromTermReferenceId ref) newRange typ
            )
   in Map Symbol TypeSignatureHint
typeHints

-- | Get info on the top-level symbols in the file.
mkDocumentSymbols :: UF.UnisonFile Symbol Ann -> Maybe (UF.TypecheckedUnisonFile Symbol Ann) -> [UDocumentSymbol]
mkDocumentSymbols :: UnisonFile Symbol Ann
-> Maybe (TypecheckedUnisonFile Symbol Ann) -> [UDocumentSymbol]
mkDocumentSymbols UnisonFile Symbol Ann
parsedFile Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile =
  let alignTerms :: These (a, b) (a, b, c, d, a) -> (a, Maybe a)
alignTerms = \case
        This (a
ann, b
_trm) -> (a
ann, Maybe a
forall a. Maybe a
Nothing)
        That (a
ann, b
_ref, c
_wk, d
_trm, a
typ) -> (a
ann, a -> Maybe a
forall a. a -> Maybe a
Just a
typ)
        These (a, b)
_ (a
ann, b
_ref, c
_wk, d
_trm, a
typ) -> (a
ann, a -> Maybe a
forall a. a -> Maybe a
Just a
typ)
      termSymbols :: [UDocumentSymbol]
      termSymbols :: [UDocumentSymbol]
termSymbols =
        (These
   (Ann, Term Symbol Ann)
   (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
    Type Symbol Ann)
 -> (Ann, Maybe (Type Symbol Ann)))
-> Map Symbol (Ann, Term Symbol Ann)
-> Map
     Symbol
     (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
      Type Symbol Ann)
-> Map Symbol (Ann, Maybe (Type Symbol Ann))
forall a b c.
(These a b -> c) -> Map Symbol a -> Map Symbol b -> Map Symbol c
forall (f :: * -> *) a b c.
Semialign f =>
(These a b -> c) -> f a -> f b -> f c
Align.alignWith These
  (Ann, Term Symbol Ann)
  (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
   Type Symbol Ann)
-> (Ann, Maybe (Type Symbol Ann))
forall {a} {b} {b} {c} {d} {a}.
These (a, b) (a, b, c, d, a) -> (a, Maybe a)
alignTerms UnisonFile Symbol Ann
parsedFile.terms (Map
  Symbol
  (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
   Type Symbol Ann)
-> (TypecheckedUnisonFile Symbol Ann
    -> Map
         Symbol
         (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
          Type Symbol Ann))
-> Maybe (TypecheckedUnisonFile Symbol Ann)
-> Map
     Symbol
     (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
      Type Symbol Ann)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map
  Symbol
  (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
   Type Symbol Ann)
forall a. Monoid a => a
mempty TypecheckedUnisonFile Symbol Ann
-> Map
     Symbol
     (Ann, TypeReferenceId, Maybe WatchKind, Term Symbol Ann,
      Type Symbol Ann)
forall v a.
TypecheckedUnisonFile v a
-> Map v (a, TypeReferenceId, Maybe WatchKind, Term v a, Type v a)
UF.hashTermsId Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile)
          Map Symbol (Ann, Maybe (Type Symbol Ann))
-> (Map Symbol (Ann, Maybe (Type Symbol Ann))
    -> [(Symbol, (Ann, Maybe (Type Symbol Ann)))])
-> [(Symbol, (Ann, Maybe (Type Symbol Ann)))]
forall a b. a -> (a -> b) -> b
& Map Symbol (Ann, Maybe (Type Symbol Ann))
-> [(Symbol, (Ann, Maybe (Type Symbol Ann)))]
forall k a. Map k a -> [(k, a)]
Map.toList
          [(Symbol, (Ann, Maybe (Type Symbol Ann)))]
-> ([(Symbol, (Ann, Maybe (Type Symbol Ann)))]
    -> [UDocumentSymbol])
-> [UDocumentSymbol]
forall a b. a -> (a -> b) -> b
& ((Symbol, (Ann, Maybe (Type Symbol Ann))) -> Maybe UDocumentSymbol)
-> [(Symbol, (Ann, Maybe (Type Symbol Ann)))] -> [UDocumentSymbol]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe \(Symbol
v, (Ann
ann, Maybe (Type Symbol Ann)
mayTyp)) -> do
            name <- Text -> Maybe Name
Name.parseText (Symbol -> Text
forall v. Var v => v -> Text
Var.name Symbol
v)
            range <- annToRange ann
            let children = []
            pure $ UDocumentSymbol name mayTyp TermSymbol range children
      declSymbols :: [UDocumentSymbol]
      declSymbols :: [UDocumentSymbol]
declSymbols =
        UnisonFile Symbol Ann
parsedFile.dataDeclarationsId
          Map Symbol (TypeReferenceId, DataDeclaration Symbol Ann)
-> (Map Symbol (TypeReferenceId, DataDeclaration Symbol Ann)
    -> [(Symbol, (TypeReferenceId, DataDeclaration Symbol Ann))])
-> [(Symbol, (TypeReferenceId, DataDeclaration Symbol Ann))]
forall a b. a -> (a -> b) -> b
& Map Symbol (TypeReferenceId, DataDeclaration Symbol Ann)
-> [(Symbol, (TypeReferenceId, DataDeclaration Symbol Ann))]
forall k a. Map k a -> [(k, a)]
Map.toList
          [(Symbol, (TypeReferenceId, DataDeclaration Symbol Ann))]
-> ([(Symbol, (TypeReferenceId, DataDeclaration Symbol Ann))]
    -> [UDocumentSymbol])
-> [UDocumentSymbol]
forall a b. a -> (a -> b) -> b
& ((Symbol, (TypeReferenceId, DataDeclaration Symbol Ann))
 -> Maybe UDocumentSymbol)
-> [(Symbol, (TypeReferenceId, DataDeclaration Symbol Ann))]
-> [UDocumentSymbol]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe \(Symbol
v, (TypeReferenceId
_ref, DataDeclaration Symbol Ann
decl)) -> do
            name <- Text -> Maybe Name
Name.parseText (Symbol -> Text
forall v. Var v => v -> Text
Var.name Symbol
v)
            range <- annToRange (DD.annotation decl)
            let children = DataDeclaration Symbol Ann -> [UDocumentSymbol]
declChildren DataDeclaration Symbol Ann
decl
            pure $ UDocumentSymbol name Nothing DataDeclSymbol range children
      effectSymbols :: [UDocumentSymbol]
      effectSymbols :: [UDocumentSymbol]
effectSymbols =
        UnisonFile Symbol Ann
parsedFile.effectDeclarationsId
          Map Symbol (TypeReferenceId, EffectDeclaration Symbol Ann)
-> (Map Symbol (TypeReferenceId, EffectDeclaration Symbol Ann)
    -> [(Symbol, (TypeReferenceId, EffectDeclaration Symbol Ann))])
-> [(Symbol, (TypeReferenceId, EffectDeclaration Symbol Ann))]
forall a b. a -> (a -> b) -> b
& Map Symbol (TypeReferenceId, EffectDeclaration Symbol Ann)
-> [(Symbol, (TypeReferenceId, EffectDeclaration Symbol Ann))]
forall k a. Map k a -> [(k, a)]
Map.toList
          [(Symbol, (TypeReferenceId, EffectDeclaration Symbol Ann))]
-> ([(Symbol, (TypeReferenceId, EffectDeclaration Symbol Ann))]
    -> [UDocumentSymbol])
-> [UDocumentSymbol]
forall a b. a -> (a -> b) -> b
& ((Symbol, (TypeReferenceId, EffectDeclaration Symbol Ann))
 -> Maybe UDocumentSymbol)
-> [(Symbol, (TypeReferenceId, EffectDeclaration Symbol Ann))]
-> [UDocumentSymbol]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe \(Symbol
v, (TypeReferenceId
_ref, EffectDeclaration Symbol Ann
eff)) -> do
            let decl :: DataDeclaration Symbol Ann
decl = EffectDeclaration Symbol Ann -> DataDeclaration Symbol Ann
forall v a. EffectDeclaration v a -> DataDeclaration v a
DD.toDataDecl EffectDeclaration Symbol Ann
eff
            name <- Text -> Maybe Name
Name.parseText (Symbol -> Text
forall v. Var v => v -> Text
Var.name Symbol
v)
            range <- annToRange (DD.annotation decl)
            let children = DataDeclaration Symbol Ann -> [UDocumentSymbol]
declChildren DataDeclaration Symbol Ann
decl
            pure $ UDocumentSymbol name Nothing EffectDeclSymbol range children
   in [UDocumentSymbol]
termSymbols [UDocumentSymbol] -> [UDocumentSymbol] -> [UDocumentSymbol]
forall a. Semigroup a => a -> a -> a
<> [UDocumentSymbol]
declSymbols [UDocumentSymbol] -> [UDocumentSymbol] -> [UDocumentSymbol]
forall a. Semigroup a => a -> a -> a
<> [UDocumentSymbol]
effectSymbols
  where
    declChildren :: DD.DataDeclaration Symbol Ann -> [UDocumentSymbol]
    declChildren :: DataDeclaration Symbol Ann -> [UDocumentSymbol]
declChildren DataDeclaration Symbol Ann
decl = do
      (ann, sym, typ) <- DataDeclaration Symbol Ann -> [(Ann, Symbol, Type Symbol Ann)]
forall v a. DataDeclaration v a -> [(a, v, Type v a)]
DD.constructors' DataDeclaration Symbol Ann
decl
      name <- maybeToList $ Name.parseText (Var.name sym)
      range <- maybeToList $ annToRange ann
      pure $ UDocumentSymbol name (Just typ) TermSymbol range []

-- | Crawl a term and find the nodes which actually influence its return type. This is useful for narrowing down a giant
-- "This let/do block has the wrong type" into "This specific line returns the wrong type"
-- This is just a heuristic.
expressionLeafNodes :: Term.Term2 vt at ap v a -> [Term.Term2 vt at ap v a]
expressionLeafNodes :: forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v a
abt =
  case Term2 vt at ap v a -> ABT (F vt at ap) v (Term2 vt at ap v a)
forall (f :: * -> *) v a. Term f v a -> ABT f v (Term f v a)
ABT.out Term2 vt at ap v a
abt of
    ABT.Var {} -> [Term2 vt at ap v a
abt]
    ABT.Cycle Term2 vt at ap v a
r -> Term2 vt at ap v a -> [Term2 vt at ap v a]
forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v a
r
    ABT.Abs v
_ Term2 vt at ap v a
r -> Term2 vt at ap v a -> [Term2 vt at ap v a]
forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v a
r
    ABT.Tm F vt at ap (Term2 vt at ap v a)
f -> case F vt at ap (Term2 vt at ap v a)
f of
      Term.Int {} -> [Term2 vt at ap v a
abt]
      Term.Nat {} -> [Term2 vt at ap v a
abt]
      Term.Float {} -> [Term2 vt at ap v a
abt]
      Term.Boolean {} -> [Term2 vt at ap v a
abt]
      Term.Text {} -> [Term2 vt at ap v a
abt]
      Term.Char {} -> [Term2 vt at ap v a
abt]
      Term.Blank {} -> [Term2 vt at ap v a
abt]
      Term.Ref {} -> [Term2 vt at ap v a
abt]
      Term.Constructor {} -> [Term2 vt at ap v a
abt]
      Term.Request {} -> [Term2 vt at ap v a
abt]
      -- Not 100% sure whether the error should appear on the handler or action, maybe both?
      Term.Handle Term2 vt at ap v a
handler Term2 vt at ap v a
_action -> Term2 vt at ap v a -> [Term2 vt at ap v a]
forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v a
handler
      Term.App Term2 vt at ap v a
_a Term2 vt at ap v a
_b -> [Term2 vt at ap v a
abt]
      Term.Ann Term2 vt at ap v a
a Type vt at
_ -> Term2 vt at ap v a -> [Term2 vt at ap v a]
forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v a
a
      Term.List {} -> [Term2 vt at ap v a
abt]
      Term.If Term2 vt at ap v a
_cond Term2 vt at ap v a
a Term2 vt at ap v a
b -> Term2 vt at ap v a -> [Term2 vt at ap v a]
forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v a
a [Term2 vt at ap v a]
-> [Term2 vt at ap v a] -> [Term2 vt at ap v a]
forall a. Semigroup a => a -> a -> a
<> Term2 vt at ap v a -> [Term2 vt at ap v a]
forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v a
b
      Term.And {} -> [Term2 vt at ap v a
abt]
      Term.Or {} -> [Term2 vt at ap v a
abt]
      Term.Lam Term2 vt at ap v a
a -> Term2 vt at ap v a -> [Term2 vt at ap v a]
forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v a
a
      Term.LetRec Bool
_isTop [Term2 vt at ap v a]
_bindings Term2 vt at ap v a
body -> Term2 vt at ap v a -> [Term2 vt at ap v a]
forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v a
body
      Term.Let Bool
_isTop Term2 vt at ap v a
_bindings Term2 vt at ap v a
body -> Term2 vt at ap v a -> [Term2 vt at ap v a]
forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v a
body
      Term.Match Term2 vt at ap v a
_a [MatchCase ap (Term2 vt at ap v a)]
cases -> [MatchCase ap (Term2 vt at ap v a)]
cases [MatchCase ap (Term2 vt at ap v a)]
-> ([MatchCase ap (Term2 vt at ap v a)] -> [Term2 vt at ap v a])
-> [Term2 vt at ap v a]
forall a b. a -> (a -> b) -> b
& (MatchCase ap (Term2 vt at ap v a) -> [Term2 vt at ap v a])
-> [MatchCase ap (Term2 vt at ap v a)] -> [Term2 vt at ap v a]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \(Term.MatchCase {Term2 vt at ap v a
matchBody :: Term2 vt at ap v a
matchBody :: forall loc a. MatchCase loc a -> a
matchBody}) -> Term2 vt at ap v a -> [Term2 vt at ap v a]
forall vt at ap v a. Term2 vt at ap v a -> [Term2 vt at ap v a]
expressionLeafNodes Term2 vt at ap v a
matchBody
      Term.TermLink {} -> [Term2 vt at ap v a
abt]
      Term.TypeLink {} -> [Term2 vt at ap v a
abt]